X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=f1328e0da7b32d8e46d55067a0df92c58b896bfa;hb=0a5613f40b0e32cf59966e6b56b807cdbe80aa7b;hp=d93fb1bdefcdeb9d5510cbeb0450f67bfc19bb65;hpb=a8dc65d6582cc8dda6a1de2862e2d6da80a78d0c;p=ghc-hetmet.git diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index d93fb1b..f1328e0 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -5,18 +5,21 @@ \begin{code} module ErrUtils ( - Message, mkLocMessage, printError, + Message, mkLocMessage, printError, pprMessageBag, Severity(..), ErrMsg, WarnMsg, - errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, + ErrorMessages, WarningMessages, + errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, Messages, errorsFound, emptyMessages, - mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, + mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, + warnIsErrorMsg, mkLongWarnMsg, ghcExit, doIfSet, doIfSet_dyn, - dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, + dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_or, + mkDumpDoc, dumpSDoc, -- * Messages during compilation putMsg, @@ -29,17 +32,15 @@ module ErrUtils ( #include "HsVersions.h" -import Module ( ModLocation(..)) import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) -import SrcLoc ( SrcSpan ) import Util ( sortLe ) import Outputable -import SrcLoc ( srcSpanStart, noSrcSpan ) +import SrcLoc import DynFlags ( DynFlags(..), DynFlag(..), dopt ) import StaticFlags ( opt_ErrorSpans ) +import Control.Monad import System.Exit ( ExitCode(..), exitWith ) -import Data.Dynamic import Data.List import System.IO @@ -48,6 +49,9 @@ import System.IO type Message = SDoc +pprMessageBag :: Bag Message -> SDoc +pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) + data Severity = SevInfo | SevWarning @@ -76,19 +80,9 @@ data ErrMsg = ErrMsg { 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 + +instance Show ErrMsg where + show em = showSDoc (errMsgShortDoc em) type WarnMsg = ErrMsg @@ -96,40 +90,59 @@ type WarnMsg = ErrMsg -- to qualify names in the message or not. mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg mkErrMsg locn print_unqual msg - = ErrMsg [locn] print_unqual msg empty + = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual + , errMsgShortDoc = msg, errMsgExtraInfo = empty } -- Variant that doesn't care about qualified/unqualified names mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg mkPlainErrMsg locn msg - = ErrMsg [locn] alwaysQualify msg empty + = ErrMsg { errMsgSpans = [locn], errMsgContext = alwaysQualify + , errMsgShortDoc = msg, errMsgExtraInfo = 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 + = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual + , errMsgShortDoc = msg, errMsgExtraInfo = extra } mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg mkWarnMsg = mkErrMsg +mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg +mkLongWarnMsg = mkLongErrMsg + +-- Variant that doesn't care about qualified/unqualified names +mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg +mkPlainWarnMsg locn msg = mkWarnMsg locn alwaysQualify msg + type Messages = (Bag WarnMsg, Bag ErrMsg) +type WarningMessages = Bag WarnMsg +type ErrorMessages = Bag ErrMsg + emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) +warnIsErrorMsg :: ErrMsg +warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.\n") + errorsFound :: DynFlags -> Messages -> Bool -- The dyn-flags are used to see if the user has specified --- -Werorr, which says that warnings should be fatal +-- -Werror, 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 :: DynFlags -> Messages -> IO () printErrorsAndWarnings dflags (warns, errs) - | no_errs && no_warns = return () - | no_errs = printBagOfWarnings dflags warns - -- Don't print any warnings if there are errors - | otherwise = printBagOfErrors dflags errs + | no_errs && no_warns = return () + | no_errs = do printBagOfWarnings dflags warns + when (dopt Opt_WarnIsError dflags) $ + errorMsg dflags $ + text "\nFailing due to -Werror.\n" + -- Don't print any warnings if there are errors + | otherwise = printBagOfErrors dflags errs where no_warns = isEmptyBag warns no_errs = isEmptyBag errs @@ -138,7 +151,7 @@ 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, + | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, errMsgExtraInfo = e, errMsgContext = unqual } <- sorted_errs ] @@ -156,7 +169,7 @@ 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, + | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, errMsgExtraInfo = e, errMsgContext = unqual } <- sorted_errs ] @@ -170,8 +183,6 @@ printBagOfWarnings dflags bag_of_warns EQ -> True GT -> False - - ghcExit :: DynFlags -> Int -> IO () ghcExit dflags val | val == 0 = exitWith ExitSuccess @@ -194,18 +205,10 @@ dumpIfSet flag hdr doc | not flag = return () | 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 - = writeDump dflags flag (mkDumpDoc hdr doc) - | otherwise = return () - dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc | dopt flag dflags || verbosity dflags >= 4 - = writeDump dflags flag (mkDumpDoc hdr doc) + = dumpSDoc dflags flag hdr doc | otherwise = return () @@ -216,11 +219,12 @@ dumpIfSet_dyn_or dflags flags hdr doc = printDump (mkDumpDoc hdr doc) | otherwise = return () +mkDumpDoc :: String -> SDoc -> SDoc mkDumpDoc hdr doc - = vcat [text "", + = vcat [blankLine, line <+> text hdr <+> line, doc, - text ""] + blankLine] where line = text (replicate 20 '=') @@ -228,11 +232,13 @@ mkDumpDoc hdr doc -- | Write out a dump. -- If --dump-to-file is set then this goes to a file. -- otherwise emit to stdout. -writeDump :: DynFlags -> DynFlag -> SDoc -> IO () -writeDump dflags dflag doc +dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO () +dumpSDoc dflags dflag hdr doc = do let mFile = chooseDumpFile dflags dflag case mFile of -- write the dump to a file + -- don't add the header in this case, we can see what kind + -- of dump it is from the filename. Just fileName -> do handle <- openFile fileName AppendMode hPrintDump handle doc @@ -240,7 +246,7 @@ writeDump dflags dflag doc -- write the dump to stdout Nothing - -> do printDump doc + -> do printDump (mkDumpDoc hdr doc) -- | Choose where to put a dump file based on DynFlags