X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FErrUtils.lhs;h=358c7ab1c86f83a56d1c54bc4d288de246e9ed70;hb=29da2cf3011c292bc4261601aff85afb13e24d54;hp=9a04b72583cbf0f1dc3f041c2f5c05eab097e6ab;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 9a04b72..358c7ab 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 SrcLoc ( SrcSpan ) import Util ( sortLt ) import Outputable import qualified Pretty -import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt ) +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} +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. -addErrLocHdrLine locn hdr msg - = mkErrDoc locn (hdr $$ msg) +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 -addWarnLocHdrLine locn hdr msg - = mkWarnDoc locn (hdr $$ msg) +type WarnMsg = ErrMsg -dontAddErrLoc :: Message -> ErrMsg -dontAddErrLoc msg = (noSrcLoc, msg defaultErrStyle) +-- 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 -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} +-- Variant that doesn't care about qualified/unqualified names +mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg +mkPlainErrMsg locn msg + = ErrMsg [locn] alwaysQualify msg empty -\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. +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} 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,17 @@ 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 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 -> Pretty.Doc pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns