X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=bc5908f884414f46c5a1d746cb8efc5fd60d6db3;hb=46aff9457fd48cfae1258739ffd4a6d889d015f5;hp=cee03cce3b5b3a4f00981bee822f119a4aad1f55;hpb=ad94d40948668032189ad22a0ad741ac1f645f50;p=ghc-hetmet.git diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index cee03cc..bc5908f 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -4,26 +4,22 @@ \section[ErrsUtils]{Utilities for error reporting} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings --- for details - module ErrUtils ( Message, mkLocMessage, printError, Severity(..), - ErrMsg, WarnMsg, + ErrMsg, WarnMsg, throwErrMsg, handleErrMsg, + ErrorMessages, WarningMessages, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, Messages, errorsFound, emptyMessages, - mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, + mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, + handleFlagWarnings, ghcExit, doIfSet, doIfSet_dyn, - dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, dumpSDoc, + dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, + mkDumpDoc, dumpSDoc, -- * Messages during compilation putMsg, @@ -36,19 +32,19 @@ 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 +import Exception -- ----------------------------------------------------------------------------- -- Basic error messages: just render a message with a source location. @@ -86,16 +82,33 @@ data ErrMsg = ErrMsg { -- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic -- whether to qualify an External Name) at the error occurrence +#if __GLASGOW_HASKELL__ >= 609 +instance Exception ErrMsg +#endif + +instance Show ErrMsg where + show em = showSDoc (errMsgShortDoc em) + +throwErrMsg :: ErrMsg -> a +#if __GLASGOW_HASKELL__ < 609 +throwErrMsg = throwDyn +#else +throwErrMsg = throw +#endif + +handleErrMsg :: (ErrMsg -> IO a) -> IO a -> IO a +#if __GLASGOW_HASKELL__ < 609 +handleErrMsg = flip catchDyn +#else +handleErrMsg = handle +#endif + -- 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 type WarnMsg = ErrMsg @@ -119,24 +132,34 @@ mkLongErrMsg locn print_unqual msg extra mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg mkWarnMsg = mkErrMsg +-- 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) 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 @@ -145,7 +168,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 ] @@ -163,7 +186,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 ] @@ -177,7 +200,24 @@ printBagOfWarnings dflags bag_of_warns EQ -> True GT -> False - +handleFlagWarnings :: DynFlags -> [Located String] -> IO () +handleFlagWarnings dflags warns + = when (dopt Opt_WarnDeprecatedFlags dflags) + (handleFlagWarnings' dflags warns) + +handleFlagWarnings' :: DynFlags -> [Located String] -> IO () +handleFlagWarnings' _ [] = return () +handleFlagWarnings' dflags warns + = do -- It would be nicer if warns :: [Located Message], but that has circular + -- import problems. + mapM_ (handleFlagWarning dflags) warns + when (dopt Opt_WarnIsError dflags) $ + do errorMsg dflags $ text "\nFailing due to -Werror.\n" + exitWith (ExitFailure 1) + +handleFlagWarning :: DynFlags -> Located String -> IO () +handleFlagWarning dflags (L loc warn) + = log_action dflags SevWarning loc defaultUserStyle (text warn) ghcExit :: DynFlags -> Int -> IO () ghcExit dflags val @@ -201,13 +241,18 @@ dumpIfSet flag hdr doc | not flag = return () | otherwise = printDump (mkDumpDoc hdr doc) +dumpIf_core :: Bool -> DynFlags -> DynFlag -> String -> SDoc -> IO () +dumpIf_core cond dflags dflag hdr doc + | cond + || verbosity dflags >= 4 + || dopt Opt_D_verbose_core2core dflags + = dumpSDoc dflags dflag hdr doc + + | otherwise = return () + 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 - = dumpSDoc dflags flag hdr doc - | otherwise = return () + = dumpIf_core (dopt flag dflags) dflags flag hdr doc dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc @@ -223,6 +268,7 @@ dumpIfSet_dyn_or dflags flags hdr doc = printDump (mkDumpDoc hdr doc) | otherwise = return () +mkDumpDoc :: String -> SDoc -> SDoc mkDumpDoc hdr doc = vcat [text "", line <+> text hdr <+> line,