e0d6a9643e31f24bf224562bd9a0fe2d6aa22a84
[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
8 module ErrUtils (
9         ErrMsg, WarnMsg, Severity(..),
10         Messages, ErrorMessages, WarningMessages,
11         errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
12         MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc,
13         pprLocErrMsg, makeIntoWarning,
14         
15         errorsFound, emptyMessages, isEmptyMessages,
16         mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
17         printBagOfErrors, 
18         warnIsErrorMsg, mkLongWarnMsg,
19
20         ghcExit,
21         doIfSet, doIfSet_dyn,
22         dumpIfSet, dumpIfSet_dyn,
23         mkDumpDoc, dumpSDoc,
24
25         --  * Messages during compilation
26         putMsg, putMsgWith,
27         errorMsg,
28         fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
29         compilationProgressMsg,
30         showPass,
31         debugTraceMsg,
32
33         prettyPrintGhcErrors,
34     ) where
35
36 #include "HsVersions.h"
37
38 import Bag              ( Bag, bagToList, isEmptyBag, emptyBag )
39 import Exception
40 import Outputable
41 import Panic
42 import FastString
43 import SrcLoc
44 import DynFlags
45
46 import System.Directory
47 import System.Exit      ( ExitCode(..), exitWith )
48 import System.FilePath
49 import Data.List
50 import qualified Data.Set as Set
51 import Data.IORef
52 import Data.Ord
53 import Data.Time
54 import Control.Monad
55 import System.IO
56
57 -- -----------------------------------------------------------------------------
58 -- Basic error messages: just render a message with a source location.
59
60 type Messages        = (WarningMessages, ErrorMessages)
61 type WarningMessages = Bag WarnMsg
62 type ErrorMessages   = Bag ErrMsg
63
64 data ErrMsg = ErrMsg {
65         errMsgSpans     :: [SrcSpan],
66         errMsgContext   :: PrintUnqualified,
67         errMsgShortDoc  :: MsgDoc,   -- errMsgShort* should always
68         errMsgShortString :: String, -- contain the same text
69         errMsgExtraInfo :: MsgDoc,
70         errMsgSeverity  :: Severity
71         }
72         -- The SrcSpan is used for sorting errors into line-number order
73
74 type WarnMsg = ErrMsg
75 type MsgDoc = SDoc
76
77 data Severity
78   = SevOutput
79   | SevDump
80   | SevInfo
81   | SevWarning
82   | SevError
83   | SevFatal
84
85 instance Show ErrMsg where
86     show em = errMsgShortString em
87
88 pprMessageBag :: Bag MsgDoc -> SDoc
89 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
90
91 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
92   -- Always print the location, even if it is unhelpful.  Error messages
93   -- are supposed to be in a standard format, and one without a location
94   -- would look strange.  Better to say explicitly "<no location info>".
95 mkLocMessage severity locn msg
96     = sdocWithDynFlags $ \dflags ->
97       let locn' = if gopt Opt_ErrorSpans dflags
98                   then ppr locn
99                   else ppr (srcSpanStart locn)
100       in hang (locn' <> colon <+> sev_info) 4 msg
101   where
102     sev_info = case severity of
103                  SevWarning -> ptext (sLit "Warning:")
104                  _other     -> empty                 
105       -- For warnings, print    Foo.hs:34: Warning:
106       --                           <the warning message>
107
108 makeIntoWarning :: ErrMsg -> ErrMsg
109 makeIntoWarning err = err { errMsgSeverity = SevWarning }
110
111 -- -----------------------------------------------------------------------------
112 -- Collecting up messages for later ordering and printing.
113
114 mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
115 mk_err_msg  dflags sev locn print_unqual msg extra
116  = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
117           , errMsgShortDoc = msg , errMsgShortString = showSDoc dflags msg
118           , errMsgExtraInfo = extra
119           , errMsgSeverity = sev }
120
121 mkLongErrMsg, mkLongWarnMsg   :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
122 -- A long (multi-line) error message
123 mkErrMsg, mkWarnMsg           :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg
124 -- A short (one-line) error message
125 mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan ->                     MsgDoc            -> ErrMsg
126 -- Variant that doesn't care about qualified/unqualified names
127
128 mkLongErrMsg   dflags locn unqual msg extra = mk_err_msg dflags SevError   locn unqual        msg extra
129 mkErrMsg       dflags locn unqual msg       = mk_err_msg dflags SevError   locn unqual        msg empty
130 mkPlainErrMsg  dflags locn        msg       = mk_err_msg dflags SevError   locn alwaysQualify msg empty
131 mkLongWarnMsg  dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual        msg extra
132 mkWarnMsg      dflags locn unqual msg       = mk_err_msg dflags SevWarning locn unqual        msg empty
133 mkPlainWarnMsg dflags locn        msg       = mk_err_msg dflags SevWarning locn alwaysQualify msg empty
134
135 ----------------
136 emptyMessages :: Messages
137 emptyMessages = (emptyBag, emptyBag)
138
139 isEmptyMessages :: Messages -> Bool
140 isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
141
142 warnIsErrorMsg :: DynFlags -> ErrMsg
143 warnIsErrorMsg dflags
144     = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
145
146 errorsFound :: DynFlags -> Messages -> Bool
147 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
148
149 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
150 printBagOfErrors dflags bag_of_errors
151   = printMsgBag dflags bag_of_errors
152
153 pprErrMsgBag :: Bag ErrMsg -> [SDoc]
154 pprErrMsgBag bag
155   = [ sdocWithDynFlags $ \dflags ->
156       let style = mkErrStyle dflags unqual
157       in withPprStyle style (d $$ e)
158     | ErrMsg { errMsgShortDoc  = d,
159                errMsgExtraInfo = e,
160                errMsgContext   = unqual } <- sortMsgBag bag ]
161
162 pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
163 pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag bag ]
164
165 pprLocErrMsg :: ErrMsg -> SDoc
166 pprLocErrMsg (ErrMsg { errMsgSpans     = spans
167                      , errMsgShortDoc  = d
168                      , errMsgExtraInfo = e
169                      , errMsgSeverity  = sev
170                      , errMsgContext   = unqual })
171   = sdocWithDynFlags $ \dflags ->
172     withPprStyle (mkErrStyle dflags unqual) (mkLocMessage sev s (d $$ e))
173   where
174     (s : _) = spans   -- Should be non-empty
175
176 printMsgBag :: DynFlags -> Bag ErrMsg -> IO ()
177 printMsgBag dflags bag
178   = sequence_ [ let style = mkErrStyle dflags unqual
179                 in log_action dflags dflags sev s style (d $$ e)
180               | ErrMsg { errMsgSpans     = s:_,
181                          errMsgShortDoc  = d,
182                          errMsgSeverity  = sev,
183                          errMsgExtraInfo = e,
184                          errMsgContext   = unqual } <- sortMsgBag bag ]
185
186 sortMsgBag :: Bag ErrMsg -> [ErrMsg]
187 sortMsgBag bag = sortBy (comparing (head . errMsgSpans)) $ bagToList bag
188                  -- TODO: Why "head ."? Why not compare the whole list?
189
190 ghcExit :: DynFlags -> Int -> IO ()
191 ghcExit dflags val
192   | val == 0  = exitWith ExitSuccess
193   | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
194                    exitWith (ExitFailure val)
195
196 doIfSet :: Bool -> IO () -> IO ()
197 doIfSet flag action | flag      = action
198                     | otherwise = return ()
199
200 doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
201 doIfSet_dyn dflags flag action | gopt flag dflags = action
202                                | otherwise        = return ()
203
204 -- -----------------------------------------------------------------------------
205 -- Dumping
206
207 dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
208 dumpIfSet dflags flag hdr doc
209   | not flag   = return ()
210   | otherwise  = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
211
212 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
213 dumpIfSet_dyn dflags flag hdr doc
214   | dopt flag dflags
215   = dumpSDoc dflags flag hdr doc
216   | otherwise
217   = return ()
218
219 mkDumpDoc :: String -> SDoc -> SDoc
220 mkDumpDoc hdr doc
221    = vcat [blankLine,
222            line <+> text hdr <+> line,
223            doc,
224            blankLine]
225      where
226         line = text (replicate 20 '=')
227
228
229 -- | Write out a dump.
230 --      If --dump-to-file is set then this goes to a file.
231 --      otherwise emit to stdout.
232 -- 
233 -- When hdr is empty, we print in a more compact format (no separators and
234 -- blank lines)
235 dumpSDoc :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
236 dumpSDoc dflags flag hdr doc
237  = do let mFile = chooseDumpFile dflags flag
238       case mFile of
239             Just fileName
240                  -> do
241                         let gdref = generatedDumps dflags
242                         gd <- readIORef gdref
243                         let append = Set.member fileName gd
244                             mode = if append then AppendMode else WriteMode
245                         when (not append) $
246                             writeIORef gdref (Set.insert fileName gd)
247                         createDirectoryIfMissing True (takeDirectory fileName)
248                         handle <- openFile fileName mode
249                         doc' <- if null hdr
250                                 then return doc
251                                 else do t <- getCurrentTime
252                                         let d = text (show t)
253                                              $$ blankLine
254                                              $$ doc
255                                         return $ mkDumpDoc hdr d
256                         defaultLogActionHPrintDoc dflags handle doc' defaultDumpStyle
257                         hClose handle
258
259             -- write the dump to stdout
260             Nothing -> do
261               let (doc', severity)
262                     | null hdr  = (doc, SevOutput)
263                     | otherwise = (mkDumpDoc hdr doc, SevDump)
264               log_action dflags dflags severity noSrcSpan defaultDumpStyle doc'
265
266
267 -- | Choose where to put a dump file based on DynFlags
268 --
269 chooseDumpFile :: DynFlags -> DumpFlag -> Maybe String
270 chooseDumpFile dflags flag
271
272         | gopt Opt_DumpToFile dflags
273         , Just prefix <- getPrefix
274         = Just $ setDir (prefix ++ (beautifyDumpName flag))
275
276         | otherwise
277         = Nothing
278
279         where getPrefix
280                  -- dump file location is being forced
281                  --      by the --ddump-file-prefix flag.
282                | Just prefix <- dumpPrefixForce dflags
283                   = Just prefix
284                  -- dump file location chosen by DriverPipeline.runPipeline
285                | Just prefix <- dumpPrefix dflags
286                   = Just prefix
287                  -- we haven't got a place to put a dump file.
288                | otherwise
289                   = Nothing
290               setDir f = case dumpDir dflags of
291                          Just d  -> d </> f
292                          Nothing ->       f
293
294 -- | Build a nice file name from name of a GeneralFlag constructor
295 beautifyDumpName :: DumpFlag -> String
296 beautifyDumpName flag
297  = let str = show flag
298        suff = case stripPrefix "Opt_D_" str of
299               Just x -> x
300               Nothing -> panic ("Bad flag name: " ++ str)
301        dash = map (\c -> if c == '_' then '-' else c) suff
302    in dash
303
304
305 -- -----------------------------------------------------------------------------
306 -- Outputting messages from the compiler
307
308 -- We want all messages to go through one place, so that we can
309 -- redirect them if necessary.  For example, when GHC is used as a
310 -- library we might want to catch all messages that GHC tries to
311 -- output and do something else with them.
312
313 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
314 ifVerbose dflags val act
315   | verbosity dflags >= val = act
316   | otherwise               = return ()
317
318 putMsg :: DynFlags -> MsgDoc -> IO ()
319 putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
320
321 putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
322 putMsgWith dflags print_unqual msg
323   = log_action dflags dflags SevInfo noSrcSpan sty msg
324   where
325     sty = mkUserStyle print_unqual AllTheWay
326
327 errorMsg :: DynFlags -> MsgDoc -> IO ()
328 errorMsg dflags msg =
329     log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
330
331 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
332 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
333
334 fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
335 fatalErrorMsg' la dflags msg =
336     la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
337
338 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
339 fatalErrorMsg'' fm msg = fm msg
340
341 compilationProgressMsg :: DynFlags -> String -> IO ()
342 compilationProgressMsg dflags msg
343   = ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg))
344
345 showPass :: DynFlags -> String -> IO ()
346 showPass dflags what
347   = ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
348
349 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
350 debugTraceMsg dflags val msg
351   = ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg)
352
353 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
354 prettyPrintGhcErrors dflags
355     = ghandle $ \e -> case e of
356                       PprPanic str doc ->
357                           pprDebugAndThen dflags panic str doc
358                       PprSorry str doc ->
359                           pprDebugAndThen dflags sorry str doc
360                       PprProgramError str doc ->
361                           pprDebugAndThen dflags pgmError str doc
362                       _ ->
363                           throw e
364 \end{code}
365