X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FErrUtils.lhs;h=358c7ab1c86f83a56d1c54bc4d288de246e9ed70;hb=29da2cf3011c292bc4261601aff85afb13e24d54;hp=a33098a42c3bfb991054cf18cacfdc52cbdcdcb3;hpb=34a10d6614fa3546b360fc13b5386b1d86848190;p=ghc-hetmet.git diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index a33098a..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, 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,73 +22,80 @@ 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 @@ -103,10 +109,10 @@ errorsFound dflags (warns, errs) | 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 @@ -114,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