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