2 % (c) The AQUA Project, Glasgow University, 1994-1998
4 \section[ErrsUtils]{Utilities for error reporting}
8 Message, mkLocMessage, printError,
11 ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
12 errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
13 Messages, errorsFound, emptyMessages,
14 mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
15 printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
20 dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
23 -- * Messages during compilation
27 compilationProgressMsg,
32 #include "HsVersions.h"
34 import Bag ( Bag, bagToList, isEmptyBag, emptyBag )
35 import Util ( sortLe )
38 import DynFlags ( DynFlags(..), DynFlag(..), dopt )
39 import StaticFlags ( opt_ErrorSpans )
42 import System.Exit ( ExitCode(..), exitWith )
48 -- -----------------------------------------------------------------------------
49 -- Basic error messages: just render a message with a source location.
59 mkLocMessage :: SrcSpan -> Message -> Message
61 | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg
62 | otherwise = hang (ppr (srcSpanStart locn) <> colon) 4 msg
63 -- always print the location, even if it is unhelpful. Error messages
64 -- are supposed to be in a standard format, and one without a location
65 -- would look strange. Better to say explicitly "<no location info>".
67 printError :: SrcSpan -> Message -> IO ()
68 printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)
71 -- -----------------------------------------------------------------------------
72 -- Collecting up messages for later ordering and printing.
74 data ErrMsg = ErrMsg {
75 errMsgSpans :: [SrcSpan],
76 errMsgContext :: PrintUnqualified,
77 errMsgShortDoc :: Message,
78 errMsgExtraInfo :: Message
80 -- The SrcSpan is used for sorting errors into line-number order
81 -- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic
82 -- whether to qualify an External Name) at the error occurrence
84 #if __GLASGOW_HASKELL__ >= 609
85 instance Exception ErrMsg
88 instance Show ErrMsg where
89 show em = showSDoc (errMsgShortDoc em)
91 throwErrMsg :: ErrMsg -> a
92 #if __GLASGOW_HASKELL__ < 609
93 throwErrMsg = throwDyn
98 handleErrMsg :: (ErrMsg -> IO a) -> IO a -> IO a
99 #if __GLASGOW_HASKELL__ < 609
100 handleErrMsg = flip catchDyn
102 handleErrMsg = handle
105 -- So we can throw these things as exceptions
107 errMsgTc = mkTyCon "ErrMsg"
108 {-# NOINLINE errMsgTc #-}
109 instance Typeable ErrMsg where
110 typeOf _ = mkTyConApp errMsgTc []
112 type WarnMsg = ErrMsg
114 -- A short (one-line) error message, with context to tell us whether
115 -- to qualify names in the message or not.
116 mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg
117 mkErrMsg locn print_unqual msg
118 = ErrMsg [locn] print_unqual msg empty
120 -- Variant that doesn't care about qualified/unqualified names
121 mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg
122 mkPlainErrMsg locn msg
123 = ErrMsg [locn] alwaysQualify msg empty
125 -- A long (multi-line) error message, with context to tell us whether
126 -- to qualify names in the message or not.
127 mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
128 mkLongErrMsg locn print_unqual msg extra
129 = ErrMsg [locn] print_unqual msg extra
131 mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
134 -- Variant that doesn't care about qualified/unqualified names
135 mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg
136 mkPlainWarnMsg locn msg = mkWarnMsg locn alwaysQualify msg
138 type Messages = (Bag WarnMsg, Bag ErrMsg)
140 emptyMessages :: Messages
141 emptyMessages = (emptyBag, emptyBag)
143 errorsFound :: DynFlags -> Messages -> Bool
144 -- The dyn-flags are used to see if the user has specified
145 -- -Werror, which says that warnings should be fatal
146 errorsFound dflags (warns, errs)
147 | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
148 | otherwise = not (isEmptyBag errs)
150 printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
151 printErrorsAndWarnings dflags (warns, errs)
152 | no_errs && no_warns = return ()
153 | no_errs = do printBagOfWarnings dflags warns
154 when (dopt Opt_WarnIsError dflags) $
156 text "\nFailing due to -Werror.\n"
157 -- Don't print any warnings if there are errors
158 | otherwise = printBagOfErrors dflags errs
160 no_warns = isEmptyBag warns
161 no_errs = isEmptyBag errs
163 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
164 printBagOfErrors dflags bag_of_errors
165 = sequence_ [ let style = mkErrStyle unqual
166 in log_action dflags SevError s style (d $$ e)
167 | ErrMsg { errMsgSpans = s:_,
170 errMsgContext = unqual } <- sorted_errs ]
172 bag_ls = bagToList bag_of_errors
173 sorted_errs = sortLe occ'ed_before bag_ls
175 occ'ed_before err1 err2 =
176 case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
181 printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO ()
182 printBagOfWarnings dflags bag_of_warns
183 = sequence_ [ let style = mkErrStyle unqual
184 in log_action dflags SevWarning s style (d $$ e)
185 | ErrMsg { errMsgSpans = s:_,
188 errMsgContext = unqual } <- sorted_errs ]
190 bag_ls = bagToList bag_of_warns
191 sorted_errs = sortLe occ'ed_before bag_ls
193 occ'ed_before err1 err2 =
194 case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
199 handleFlagWarnings :: DynFlags -> [Located String] -> IO ()
200 handleFlagWarnings dflags warns
201 = when (dopt Opt_WarnDeprecatedFlags dflags)
202 (handleFlagWarnings' dflags warns)
204 handleFlagWarnings' :: DynFlags -> [Located String] -> IO ()
205 handleFlagWarnings' _ [] = return ()
206 handleFlagWarnings' dflags warns
207 = do -- It would be nicer if warns :: [Located Message], but that has circular
209 mapM_ (handleFlagWarning dflags) warns
210 when (dopt Opt_WarnIsError dflags) $
211 do errorMsg dflags $ text "\nFailing due to -Werror.\n"
212 exitWith (ExitFailure 1)
214 handleFlagWarning :: DynFlags -> Located String -> IO ()
215 handleFlagWarning dflags (L loc warn)
216 = log_action dflags SevWarning loc defaultUserStyle (text warn)
218 ghcExit :: DynFlags -> Int -> IO ()
220 | val == 0 = exitWith ExitSuccess
221 | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
222 exitWith (ExitFailure val)
224 doIfSet :: Bool -> IO () -> IO ()
225 doIfSet flag action | flag = action
226 | otherwise = return ()
228 doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
229 doIfSet_dyn dflags flag action | dopt flag dflags = action
230 | otherwise = return ()
232 -- -----------------------------------------------------------------------------
235 dumpIfSet :: Bool -> String -> SDoc -> IO ()
236 dumpIfSet flag hdr doc
237 | not flag = return ()
238 | otherwise = printDump (mkDumpDoc hdr doc)
240 dumpIf_core :: Bool -> DynFlags -> DynFlag -> String -> SDoc -> IO ()
241 dumpIf_core cond dflags dflag hdr doc
243 || verbosity dflags >= 4
244 || dopt Opt_D_verbose_core2core dflags
245 = dumpSDoc dflags dflag hdr doc
247 | otherwise = return ()
249 dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
250 dumpIfSet_core dflags flag hdr doc
251 = dumpIf_core (dopt flag dflags) dflags flag hdr doc
253 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
254 dumpIfSet_dyn dflags flag hdr doc
255 | dopt flag dflags || verbosity dflags >= 4
256 = dumpSDoc dflags flag hdr doc
260 dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
261 dumpIfSet_dyn_or dflags flags hdr doc
262 | or [dopt flag dflags | flag <- flags]
263 || verbosity dflags >= 4
264 = printDump (mkDumpDoc hdr doc)
265 | otherwise = return ()
267 mkDumpDoc :: String -> SDoc -> SDoc
270 line <+> text hdr <+> line,
274 line = text (replicate 20 '=')
277 -- | Write out a dump.
278 -- If --dump-to-file is set then this goes to a file.
279 -- otherwise emit to stdout.
280 dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
281 dumpSDoc dflags dflag hdr doc
282 = do let mFile = chooseDumpFile dflags dflag
284 -- write the dump to a file
285 -- don't add the header in this case, we can see what kind
286 -- of dump it is from the filename.
288 -> do handle <- openFile fileName AppendMode
289 hPrintDump handle doc
292 -- write the dump to stdout
294 -> do printDump (mkDumpDoc hdr doc)
297 -- | Choose where to put a dump file based on DynFlags
299 chooseDumpFile :: DynFlags -> DynFlag -> Maybe String
300 chooseDumpFile dflags dflag
302 -- dump file location is being forced
303 -- by the --ddump-file-prefix flag.
305 , Just prefix <- dumpPrefixForce dflags
306 = Just $ prefix ++ (beautifyDumpName dflag)
308 -- dump file location chosen by DriverPipeline.runPipeline
310 , Just prefix <- dumpPrefix dflags
311 = Just $ prefix ++ (beautifyDumpName dflag)
313 -- we haven't got a place to put a dump file.
317 where dumpToFile = dopt Opt_DumpToFile dflags
320 -- | Build a nice file name from name of a DynFlag constructor
321 beautifyDumpName :: DynFlag -> String
322 beautifyDumpName dflag
323 = let str = show dflag
324 cut = if isPrefixOf "Opt_D_" str
327 dash = map (\c -> case c of
334 -- -----------------------------------------------------------------------------
335 -- Outputting messages from the compiler
337 -- We want all messages to go through one place, so that we can
338 -- redirect them if necessary. For example, when GHC is used as a
339 -- library we might want to catch all messages that GHC tries to
340 -- output and do something else with them.
342 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
343 ifVerbose dflags val act
344 | verbosity dflags >= val = act
345 | otherwise = return ()
347 putMsg :: DynFlags -> Message -> IO ()
348 putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
350 errorMsg :: DynFlags -> Message -> IO ()
351 errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
353 fatalErrorMsg :: DynFlags -> Message -> IO ()
354 fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg
356 compilationProgressMsg :: DynFlags -> String -> IO ()
357 compilationProgressMsg dflags msg
358 = ifVerbose dflags 1 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text msg))
360 showPass :: DynFlags -> String -> IO ()
362 = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
364 debugTraceMsg :: DynFlags -> Int -> Message -> IO ()
365 debugTraceMsg dflags val msg
366 = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)