X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FErrUtils.lhs;h=90e5dc87b6a204cdf98fc6d0f42e377df1527cc9;hb=78b72ed1e0ffab668e0d4bb31657942970515e4f;hp=358c7ab1c86f83a56d1c54bc4d288de246e9ed70;hpb=29da2cf3011c292bc4261601aff85afb13e24d54;p=ghc-hetmet.git diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 358c7ab..90e5dc8 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -6,33 +6,41 @@ \begin{code} module ErrUtils ( Message, mkLocMessage, printError, + Severity(..), ErrMsg, WarnMsg, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, Messages, errorsFound, emptyMessages, mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, - printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings, + printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, ghcExit, doIfSet, doIfSet_dyn, - dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, - showPass + dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, + + -- * Messages during compilation + putMsg, + errorMsg, + fatalErrorMsg, + compilationProgressMsg, + showPass, + debugTraceMsg, ) where #include "HsVersions.h" import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) import SrcLoc ( SrcSpan ) -import Util ( sortLt ) +import Util ( sortLe, global ) import Outputable import qualified Pretty -import SrcLoc ( srcSpanStart ) -import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt, - opt_ErrorSpans ) - -import List ( replicate ) +import SrcLoc ( srcSpanStart, noSrcSpan ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt ) +import StaticFlags ( opt_ErrorSpans ) import System ( ExitCode(..), exitWith ) -import IO ( hPutStr, stderr, stdout ) +import DATA_IOREF +import IO ( hPutStrLn, stderr ) +import DYNAMIC -- ----------------------------------------------------------------------------- @@ -40,6 +48,12 @@ import IO ( hPutStr, stderr, stdout ) type Message = SDoc +data Severity + = SevInfo + | SevWarning + | SevError + | SevFatal + mkLocMessage :: SrcSpan -> Message -> Message mkLocMessage locn msg | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg @@ -65,6 +79,17 @@ 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 +-- 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 -- A short (one-line) error message, with context to tell us whether @@ -84,18 +109,9 @@ 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 - type Messages = (Bag WarnMsg, Bag ErrMsg) emptyMessages :: Messages @@ -108,39 +124,58 @@ errorsFound dflags (warns, errs) | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns) | otherwise = not (isEmptyBag errs) -printErrorsAndWarnings :: Messages -> IO () -printErrorsAndWarnings (warns, errs) +printErrorsAndWarnings :: DynFlags -> Messages -> IO () +printErrorsAndWarnings dflags (warns, errs) | no_errs && no_warns = return () - | no_errs = printErrs (pprBagOfWarnings warns) + | no_errs = printBagOfWarnings dflags warns -- Don't print any warnings if there are errors - | otherwise = printErrs (pprBagOfErrors errs) + | otherwise = printBagOfErrors dflags errs where no_warns = isEmptyBag warns no_errs = isEmptyBag errs -pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc -pprBagOfErrors bag_of_errors - = Pretty.vcat [ let style = mkErrStyle unqual in - Pretty.text "" Pretty.$$ d style Pretty.$$ e style - | ErrMsg { errMsgShortDoc = d, +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, + 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 err1 err2 = - LT == compare (head (errMsgSpans err1)) (head (errMsgSpans err1)) + case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of + LT -> True + EQ -> True + GT -> False + +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, + errMsgShortDoc = d, + errMsgExtraInfo = e, + errMsgContext = unqual } <- sorted_errs ] + where + bag_ls = bagToList bag_of_warns + sorted_errs = sortLe occ'ed_before bag_ls -pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc -pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns + occ'ed_before err1 err2 = + case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of + LT -> True + EQ -> True + GT -> False \end{code} \begin{code} -ghcExit :: Int -> IO () -ghcExit val +ghcExit :: DynFlags -> Int -> IO () +ghcExit dflags val | val == 0 = exitWith ExitSuccess - | otherwise = do hPutStr stderr "\nCompilation had errors\n\n" + | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") exitWith (ExitFailure val) \end{code} @@ -155,11 +190,6 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action \end{code} \begin{code} -showPass :: DynFlags -> String -> IO () -showPass dflags what - | verbosity dflags >= 2 = hPutStr stderr ("*** "++what++":\n") - | otherwise = return () - dumpIfSet :: Bool -> String -> SDoc -> IO () dumpIfSet flag hdr doc | not flag = return () @@ -175,9 +205,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 () @@ -195,4 +223,38 @@ mkDumpDoc hdr doc text ""] where line = text (replicate 20 '=') + +-- ----------------------------------------------------------------------------- +-- Outputting messages from the compiler + +-- We want all messages to go through one place, so that we can +-- redirect them if necessary. For example, when GHC is used as a +-- library we might want to catch all messages that GHC tries to +-- output and do something else with them. + +ifVerbose :: DynFlags -> Int -> IO () -> IO () +ifVerbose dflags val act + | verbosity dflags >= val = act + | otherwise = return () + +putMsg :: DynFlags -> Message -> IO () +putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg + +errorMsg :: DynFlags -> Message -> IO () +errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg + +fatalErrorMsg :: DynFlags -> Message -> IO () +fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg + +compilationProgressMsg :: DynFlags -> String -> IO () +compilationProgressMsg dflags msg + = ifVerbose dflags 1 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text msg)) + +showPass :: DynFlags -> String -> IO () +showPass dflags what + = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) + +debugTraceMsg :: DynFlags -> Int -> Message -> IO () +debugTraceMsg dflags val msg + = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) \end{code}