X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FErrUtils.lhs;h=bf9a663e5e2bc77e7b8103b5a7039a70d7355adf;hb=59c796f8e77325d35f29ddd3e724bfa780466d40;hp=9a04b72583cbf0f1dc3f041c2f5c05eab097e6ab;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 9a04b72..bf9a663 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -5,15 +5,14 @@ \begin{code} module ErrUtils ( - ErrMsg, WarnMsg, Message, - Messages, errorsFound, warningsFound, emptyMessages, - - 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, mkDumpDoc, @@ -23,89 +22,97 @@ module ErrUtils ( #include "HsVersions.h" import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) -import SrcLoc ( SrcLoc, noSrcLoc, isGoodSrcLoc ) -import Util ( sortLt ) +import SrcLoc ( SrcSpan ) +import Util ( sortLe ) import Outputable import qualified Pretty -import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt ) +import SrcLoc ( srcSpanStart ) +import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt, + opt_ErrorSpans ) -import List ( replicate ) +import List ( replicate, sortBy ) import System ( ExitCode(..), exitWith ) -import IO ( hPutStr, hPutStrLn, stderr, stdout ) -\end{code} +import IO ( hPutStr, stderr, stdout ) -\begin{code} -type MsgWithLoc = (SrcLoc, Pretty.Doc) - -- The SrcLoc 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 ErrMsg = MsgWithLoc -type WarnMsg = MsgWithLoc +-- ----------------------------------------------------------------------------- +-- Basic error messages: just render a message with a source location. + type Message = SDoc -addShortErrLocLine :: SrcLoc -> PrintUnqualified -> Message -> ErrMsg -addShortWarnLocLine :: SrcLoc -> PrintUnqualified -> Message -> WarnMsg - -- Used heavily by renamer/typechecker - -- Be refined about qualification, return an ErrMsg +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 :: SrcLoc -> Message -> Message -> Message -addWarnLocHdrLine :: SrcLoc -> Message -> Message -> Message - -- Used by Lint and other system stuff - -- Always print qualified, return a Message +printError :: SrcSpan -> Message -> IO () +printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle) -addShortErrLocLine locn print_unqual msg - = (locn, doc (mkErrStyle print_unqual)) - where - doc = mkErrDoc locn msg -addShortWarnLocLine locn print_unqual msg - = (locn, doc (mkErrStyle print_unqual)) - where - doc = mkWarnDoc locn msg +-- ----------------------------------------------------------------------------- +-- 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 -addErrLocHdrLine locn hdr msg - = mkErrDoc locn (hdr $$ msg) +type WarnMsg = ErrMsg -addWarnLocHdrLine locn hdr msg - = mkWarnDoc locn (hdr $$ msg) +-- 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 -dontAddErrLoc :: Message -> ErrMsg -dontAddErrLoc msg = (noSrcLoc, msg defaultErrStyle) +-- Variant that doesn't care about qualified/unqualified names +mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg +mkPlainErrMsg locn msg + = ErrMsg [locn] alwaysQualify msg empty -mkErrDoc locn msg - | isGoodSrcLoc locn = hang (ppr locn <> colon) 4 msg - | otherwise = msg - -mkWarnDoc locn msg - | isGoodSrcLoc locn = hang (ppr locn <> colon) 4 warn_msg - | otherwise = warn_msg - where - warn_msg = ptext SLIT("Warning:") <+> msg -\end{code} +-- 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 -\begin{code} -printError :: String -> IO () -printError str = hPutStrLn stderr str -\end{code} +-- 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} type Messages = (Bag WarnMsg, Bag ErrMsg) emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) -errorsFound :: Messages -> Bool -errorsFound (warns, errs) = not (isEmptyBag errs) - -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 :: Messages -> IO () - -- Don't print any warnings if there are errors printErrorsAndWarnings (warns, errs) | no_errs && no_warns = return () | no_errs = printErrs (pprBagOfWarnings warns) + -- Don't print any warnings if there are errors | otherwise = printErrs (pprBagOfErrors errs) where no_warns = isEmptyBag warns @@ -113,12 +120,23 @@ printErrorsAndWarnings (warns, errs) pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc pprBagOfErrors bag_of_errors - = Pretty.vcat [Pretty.text "" Pretty.$$ p | (_,p) <- sorted_errs ] + = Pretty.vcat [ let style = mkErrStyle unqual + doc = mkLocMessage s (d $$ e) + in + Pretty.text "" Pretty.$$ doc style + | 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 (a,_) (b,_) = LT == compare a b + occ'ed_before err1 err2 = + case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of + LT -> True + EQ -> True + GT -> False pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns @@ -163,9 +181,7 @@ dumpIfSet_core dflags flag hdr doc 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 (mkDumpDoc hdr doc) - else printDump (mkDumpDoc hdr doc) + = printDump (mkDumpDoc hdr doc) | otherwise = return ()