X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FErrUtils.lhs;h=90e5dc87b6a204cdf98fc6d0f42e377df1527cc9;hb=479cc24837aa2c14c3bbed323bb640a5c53a2522;hp=b0e0b3a6380b215d84b1e5a04513a6b9277347ec;hpb=f23ba2b294429ccbdeb80f0344ec08f6abf61bb7;p=ghc-hetmet.git diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index b0e0b3a..90e5dc8 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -5,96 +5,177 @@ \begin{code} module ErrUtils ( - ErrMsg, WarnMsg, Message, Messages, errorsFound, + Message, mkLocMessage, printError, + Severity(..), - addShortErrLocLine, addShortWarnLocLine, - addErrLocHdrLine, dontAddErrLoc, - - printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings, + ErrMsg, WarnMsg, + errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, + Messages, errorsFound, emptyMessages, + mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, + printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, ghcExit, - doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_dyn, showPass + doIfSet, doIfSet_dyn, + dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, + + -- * Messages during compilation + putMsg, + errorMsg, + fatalErrorMsg, + compilationProgressMsg, + showPass, + debugTraceMsg, ) where #include "HsVersions.h" -import Bag ( Bag, bagToList, isEmptyBag ) -import SrcLoc ( SrcLoc, noSrcLoc, isGoodSrcLoc ) -import Util ( sortLt ) +import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) +import SrcLoc ( SrcSpan ) +import Util ( sortLe, global ) import Outputable -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) - +import qualified Pretty +import SrcLoc ( srcSpanStart, noSrcSpan ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt ) +import StaticFlags ( opt_ErrorSpans ) import System ( ExitCode(..), exitWith ) -import IO ( hPutStr, stderr ) -\end{code} +import DATA_IOREF +import IO ( hPutStrLn, stderr ) +import DYNAMIC -\begin{code} -type MsgWithLoc = (SrcLoc, SDoc) -type ErrMsg = MsgWithLoc -type WarnMsg = MsgWithLoc +-- ----------------------------------------------------------------------------- +-- Basic error messages: just render a message with a source location. + type Message = SDoc -addShortErrLocLine :: SrcLoc -> Message -> ErrMsg -addErrLocHdrLine :: SrcLoc -> Message -> Message -> ErrMsg -addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg +data Severity + = SevInfo + | SevWarning + | SevError + | SevFatal -addShortErrLocLine locn rest_of_err_msg - | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4 - rest_of_err_msg) - | otherwise = (locn, rest_of_err_msg) +mkLocMessage :: SrcSpan -> Message -> Message +mkLocMessage locn msg + | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg + | otherwise = hang (ppr (srcSpanStart locn) <> colon) 4 msg + -- always print the location, even if it is unhelpful. Error messages + -- are supposed to be in a standard format, and one without a location + -- would look strange. Better to say explicitly "". -addErrLocHdrLine locn hdr rest_of_err_msg - = ( locn - , hang (ppr locn <> colon<+> hdr) - 4 rest_of_err_msg - ) +printError :: SrcSpan -> Message -> IO () +printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle) -addShortWarnLocLine locn rest_of_err_msg - | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4 - (ptext SLIT("Warning:") <+> rest_of_err_msg)) - | otherwise = (locn, rest_of_err_msg) -dontAddErrLoc :: Message -> ErrMsg -dontAddErrLoc msg = (noSrcLoc, msg) +-- ----------------------------------------------------------------------------- +-- Collecting up messages for later ordering and printing. -\end{code} +data ErrMsg = ErrMsg { + errMsgSpans :: [SrcSpan], + errMsgContext :: PrintUnqualified, + errMsgShortDoc :: Message, + errMsgExtraInfo :: Message + } + -- The SrcSpan is used for sorting errors into line-number order + -- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic + -- whether to qualify an External Name) at the error occurrence +-- So we can throw these things as exceptions +errMsgTc :: TyCon +errMsgTc = mkTyCon "ErrMsg" +{-# NOINLINE errMsgTc #-} +instance Typeable ErrMsg where +#if __GLASGOW_HASKELL__ < 603 + typeOf _ = mkAppTy errMsgTc [] +#else + typeOf _ = mkTyConApp errMsgTc [] +#endif + +type WarnMsg = ErrMsg + +-- A short (one-line) error message, with context to tell us whether +-- to qualify names in the message or not. +mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg +mkErrMsg locn print_unqual msg + = ErrMsg [locn] print_unqual msg empty + +-- Variant that doesn't care about qualified/unqualified names +mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg +mkPlainErrMsg locn msg + = ErrMsg [locn] alwaysQualify msg empty + +-- A long (multi-line) error message, with context to tell us whether +-- to qualify names in the message or not. +mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg +mkLongErrMsg locn print_unqual msg extra + = ErrMsg [locn] print_unqual msg extra + +mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg +mkWarnMsg = mkErrMsg -\begin{code} type Messages = (Bag WarnMsg, Bag ErrMsg) -errorsFound :: Messages -> Bool -errorsFound (warns, errs) = not (isEmptyBag errs) +emptyMessages :: Messages +emptyMessages = (emptyBag, emptyBag) + +errorsFound :: DynFlags -> Messages -> Bool +-- The dyn-flags are used to see if the user has specified +-- -Werorr, which says that warnings should be fatal +errorsFound dflags (warns, errs) + | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns) + | otherwise = not (isEmptyBag errs) -printErrorsAndWarnings :: PrintUnqualified -> Messages -> IO () - -- Don't print any warnings if there are errors -printErrorsAndWarnings unqual (warns, errs) +printErrorsAndWarnings :: DynFlags -> Messages -> IO () +printErrorsAndWarnings dflags (warns, errs) | no_errs && no_warns = return () - | no_errs = printErrs unqual (pprBagOfWarnings warns) - | otherwise = printErrs unqual (pprBagOfErrors errs) + | no_errs = printBagOfWarnings dflags warns + -- Don't print any warnings if there are errors + | otherwise = printBagOfErrors dflags errs where no_warns = isEmptyBag warns no_errs = isEmptyBag errs -pprBagOfErrors :: Bag ErrMsg -> SDoc -pprBagOfErrors bag_of_errors - = vcat [text "" $$ p | (_,p) <- sorted_errs ] +printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () +printBagOfErrors dflags bag_of_errors + = sequence_ [ let style = mkErrStyle unqual + in log_action dflags SevError s style (d $$ e) + | ErrMsg { errMsgSpans = s:ss, + errMsgShortDoc = d, + errMsgExtraInfo = e, + errMsgContext = unqual } <- sorted_errs ] where bag_ls = bagToList bag_of_errors - sorted_errs = sortLt occ'ed_before bag_ls + sorted_errs = sortLe occ'ed_before bag_ls + + occ'ed_before err1 err2 = + case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of + LT -> True + EQ -> True + GT -> False - occ'ed_before (a,_) (b,_) = LT == compare a b +printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO () +printBagOfWarnings dflags bag_of_warns + = sequence_ [ let style = mkErrStyle unqual + in log_action dflags SevWarning s style (d $$ e) + | ErrMsg { errMsgSpans = s:ss, + errMsgShortDoc = d, + errMsgExtraInfo = e, + errMsgContext = unqual } <- sorted_errs ] + where + bag_ls = bagToList bag_of_warns + sorted_errs = sortLe occ'ed_before bag_ls -pprBagOfWarnings :: Bag WarnMsg -> SDoc -pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns + occ'ed_before err1 err2 = + case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of + LT -> True + EQ -> True + GT -> False \end{code} \begin{code} -ghcExit :: Int -> IO () -ghcExit val +ghcExit :: DynFlags -> Int -> IO () +ghcExit dflags val | val == 0 = exitWith ExitSuccess - | otherwise = do hPutStr stderr "\nCompilation had errors\n\n" + | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") exitWith (ExitFailure val) \end{code} @@ -109,26 +190,71 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action \end{code} \begin{code} -showPass :: DynFlags -> String -> IO () -showPass dflags what - | dopt Opt_D_show_passes dflags = hPutStr stderr ("*** "++what++":\n") - | otherwise = return () - dumpIfSet :: Bool -> String -> SDoc -> IO () dumpIfSet flag hdr doc | not flag = return () - | otherwise = printDump (dump hdr doc) + | otherwise = printDump (mkDumpDoc hdr doc) + +dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO () +dumpIfSet_core dflags flag hdr doc + | dopt flag dflags + || verbosity dflags >= 4 + || dopt Opt_D_verbose_core2core dflags = printDump (mkDumpDoc hdr doc) + | otherwise = return () dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc - | not (dopt flag dflags) = return () - | otherwise = printDump (dump hdr doc) + | dopt flag dflags || verbosity dflags >= 4 + = printDump (mkDumpDoc hdr doc) + | otherwise + = return () -dump hdr doc +dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO () +dumpIfSet_dyn_or dflags flags hdr doc + | or [dopt flag dflags | flag <- flags] + || verbosity dflags >= 4 + = printDump (mkDumpDoc hdr doc) + | otherwise = return () + +mkDumpDoc hdr doc = vcat [text "", line <+> text hdr <+> line, doc, text ""] where - line = text (take 20 (repeat '=')) + line = text (replicate 20 '=') + +-- ----------------------------------------------------------------------------- +-- Outputting messages from the compiler + +-- We want all messages to go through one place, so that we can +-- redirect them if necessary. For example, when GHC is used as a +-- library we might want to catch all messages that GHC tries to +-- output and do something else with them. + +ifVerbose :: DynFlags -> Int -> IO () -> IO () +ifVerbose dflags val act + | verbosity dflags >= val = act + | otherwise = return () + +putMsg :: DynFlags -> Message -> IO () +putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg + +errorMsg :: DynFlags -> Message -> IO () +errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg + +fatalErrorMsg :: DynFlags -> Message -> IO () +fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg + +compilationProgressMsg :: DynFlags -> String -> IO () +compilationProgressMsg dflags msg + = ifVerbose dflags 1 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text msg)) + +showPass :: DynFlags -> String -> IO () +showPass dflags what + = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) + +debugTraceMsg :: DynFlags -> Int -> Message -> IO () +debugTraceMsg dflags val msg + = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) \end{code}