X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FErrUtils.lhs;h=358c7ab1c86f83a56d1c54bc4d288de246e9ed70;hb=29da2cf3011c292bc4261601aff85afb13e24d54;hp=c8beedd89f271ca7f4bb05b6e3e600d02e47f365;hpb=d11e681f219f6e38c2e5bc87adfb66f82de5ea65;p=ghc-hetmet.git diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index c8beedd..358c7ab 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -5,106 +5,134 @@ \begin{code} module ErrUtils ( - ErrMsg, WarnMsg, Message, Messages, errorsFound, warningsFound, - - addShortErrLocLine, addShortWarnLocLine, - addErrLocHdrLine, addWarnLocHdrLine, dontAddErrLoc, + Message, mkLocMessage, printError, + ErrMsg, WarnMsg, + errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, + Messages, errorsFound, emptyMessages, + mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings, - printError, ghcExit, doIfSet, doIfSet_dyn, - dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, + dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, showPass ) where #include "HsVersions.h" -import Bag ( Bag, bagToList, isEmptyBag ) -import SrcLoc ( SrcLoc, noSrcLoc, isGoodSrcLoc ) +import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) +import SrcLoc ( SrcSpan ) import Util ( sortLt ) import Outputable -import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt ) +import qualified Pretty +import SrcLoc ( srcSpanStart ) +import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt, + opt_ErrorSpans ) import List ( replicate ) import System ( ExitCode(..), exitWith ) -import IO ( hPutStr, hPutStrLn, stderr, stdout ) -\end{code} - -\begin{code} -type MsgWithLoc = (SrcLoc, SDoc) - -type ErrMsg = MsgWithLoc -type WarnMsg = MsgWithLoc -type Message = SDoc - -addShortErrLocLine :: SrcLoc -> Message -> ErrMsg -addErrLocHdrLine :: SrcLoc -> Message -> Message -> ErrMsg -addWarnLocHdrLine :: SrcLoc -> Message -> Message -> ErrMsg -addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg - -addShortErrLocLine locn rest_of_err_msg - | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4 - rest_of_err_msg) - | otherwise = (locn, rest_of_err_msg) +import IO ( hPutStr, stderr, stdout ) -addErrLocHdrLine locn hdr rest_of_err_msg - = ( locn - , hang (ppr locn <> colon<+> hdr) - 4 rest_of_err_msg - ) -addWarnLocHdrLine locn hdr rest_of_err_msg - = ( locn - , hang (ppr locn <> colon <+> ptext SLIT("Warning:") <+> hdr) - 4 (rest_of_err_msg) - ) +-- ----------------------------------------------------------------------------- +-- Basic error messages: just render a message with a source location. -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) +type Message = SDoc -\end{code} +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 "". + +printError :: SrcSpan -> Message -> IO () +printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle) + + +-- ----------------------------------------------------------------------------- +-- Collecting up messages for later ordering and printing. + +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 + +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 + +-- A long (multi-line) error message, with context to tell us whether +-- to qualify names in the message or not. +mkLongMultiLocErrMsg :: [SrcSpan] -> PrintUnqualified -> Message -> Message -> ErrMsg +mkLongMultiLocErrMsg locns print_unqual msg extra + = ErrMsg locns print_unqual msg extra + +mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg +mkWarnMsg = mkErrMsg + +mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> WarnMsg +mkLongWarnMsg = mkLongErrMsg -\begin{code} -printError :: String -> IO () -printError str = hPutStrLn stderr str -\end{code} - -\begin{code} type Messages = (Bag WarnMsg, Bag ErrMsg) -errorsFound :: Messages -> Bool -errorsFound (warns, errs) = not (isEmptyBag errs) +emptyMessages :: Messages +emptyMessages = (emptyBag, emptyBag) -warningsFound :: Messages -> Bool -warningsFound (warns, errs) = not (isEmptyBag warns) +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 :: Messages -> IO () +printErrorsAndWarnings (warns, errs) | no_errs && no_warns = return () - | no_errs = printErrs unqual (pprBagOfWarnings warns) - | otherwise = printErrs unqual (pprBagOfErrors errs) + | no_errs = printErrs (pprBagOfWarnings warns) + -- Don't print any warnings if there are errors + | otherwise = printErrs (pprBagOfErrors errs) where no_warns = isEmptyBag warns no_errs = isEmptyBag errs -pprBagOfErrors :: Bag ErrMsg -> SDoc +pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc pprBagOfErrors bag_of_errors - = vcat [text "" $$ p | (_,p) <- sorted_errs ] + = Pretty.vcat [ let style = mkErrStyle unqual in + Pretty.text "" Pretty.$$ d style Pretty.$$ e style + | ErrMsg { errMsgShortDoc = d, + errMsgExtraInfo = e, + errMsgContext = unqual } <- sorted_errs ] where bag_ls = bagToList bag_of_errors sorted_errs = sortLt occ'ed_before bag_ls - occ'ed_before (a,_) (b,_) = LT == compare a b + occ'ed_before err1 err2 = + LT == compare (head (errMsgSpans err1)) (head (errMsgSpans err1)) -pprBagOfWarnings :: Bag WarnMsg -> SDoc +pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns \end{code} @@ -135,21 +163,21 @@ showPass dflags what 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 (dump hdr doc) + || 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 | dopt flag dflags || verbosity dflags >= 4 = if flag `elem` [Opt_D_dump_stix, Opt_D_dump_asm] - then printForC stdout (dump hdr doc) - else printDump (dump hdr doc) + then printForC stdout (mkDumpDoc hdr doc) + else printDump (mkDumpDoc hdr doc) | otherwise = return () @@ -157,10 +185,10 @@ 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 (dump hdr doc) + = printDump (mkDumpDoc hdr doc) | otherwise = return () -dump hdr doc +mkDumpDoc hdr doc = vcat [text "", line <+> text hdr <+> line, doc,