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