X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FErrUtils.lhs;h=50db73c3b4c13ef806de30631e08ae635f6011d8;hb=10aa5c536b19b85ef5a8ddca451ccb64e45fc5e5;hp=ecad68951a6b0dd88fc6ebefdc0a2b5878169df6;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index ecad689..50db73c 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -8,35 +8,43 @@ module ErrUtils ( Message, mkLocMessage, printError, ErrMsg, WarnMsg, + errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, Messages, errorsFound, emptyMessages, - mkErrMsg, mkWarnMsg, + mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings, ghcExit, doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, - showPass + showPass, + + -- * Messages during compilation + setMsgHandler, + putMsg, + compilationProgressMsg, + debugTraceMsg, + errorMsg, ) 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 DynFlags ( DynFlags(..), DynFlag(..), dopt ) +import StaticFlags ( opt_ErrorSpans ) import System ( ExitCode(..), exitWith ) -import IO ( hPutStr, stderr, stdout ) -\end{code} +import DATA_IOREF +import IO ( hPutStrLn, stderr ) +import DYNAMIC -Basic error messages: just render a message with a source location. -\begin{code} +-- ----------------------------------------------------------------------------- +-- Basic error messages: just render a message with a source location. + type Message = SDoc mkLocMessage :: SrcSpan -> Message -> Message @@ -49,23 +57,50 @@ mkLocMessage locn msg printError :: SrcSpan -> Message -> IO () printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle) -\end{code} -Collecting up messages for later ordering and printing. -\begin{code} -data ErrMsg = ErrMsg SrcSpan Pretty.Doc +-- ----------------------------------------------------------------------------- +-- Collecting up messages for later ordering and printing. + +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 +-- 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 --- These two are used heavily by renamer/typechecker. --- Be refined about qualification, return an ErrMsg +-- 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 (mkLocMessage locn msg $ mkErrStyle print_unqual) + = ErrMsg [locn] print_unqual msg empty + +-- Variant that doesn't care about qualified/unqualified names +mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg +mkPlainErrMsg locn msg + = ErrMsg [locn] alwaysQualify msg 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 mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg mkWarnMsg = mkErrMsg @@ -83,10 +118,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 @@ -94,12 +129,23 @@ printErrorsAndWarnings (warns, errs) pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc pprBagOfErrors bag_of_errors - = Pretty.vcat [Pretty.text "" Pretty.$$ e | ErrMsg _ e <- sorted_errs ] + = Pretty.vcat [ let style = mkErrStyle unqual + doc = mkLocMessage s (d $$ e) + in + Pretty.text "" Pretty.$$ doc style + | 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 (ErrMsg l1 _) (ErrMsg l2 _) = LT == compare l1 l2 + occ'ed_before err1 err2 = + case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of + LT -> True + EQ -> True + GT -> False pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns @@ -109,7 +155,7 @@ pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns ghcExit :: Int -> IO () ghcExit val | val == 0 = exitWith ExitSuccess - | otherwise = do hPutStr stderr "\nCompilation had errors\n\n" + | otherwise = do errorMsg "\nCompilation had errors\n\n" exitWith (ExitFailure val) \end{code} @@ -125,9 +171,7 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action \begin{code} showPass :: DynFlags -> String -> IO () -showPass dflags what - | verbosity dflags >= 2 = hPutStr stderr ("*** "++what++":\n") - | otherwise = return () +showPass dflags what = compilationPassMsg dflags ("*** "++what++":") dumpIfSet :: Bool -> String -> SDoc -> IO () dumpIfSet flag hdr doc @@ -144,9 +188,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 () @@ -164,4 +206,40 @@ 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 () + +errorMsg :: String -> IO () +errorMsg = putMsg + +compilationProgressMsg :: DynFlags -> String -> IO () +compilationProgressMsg dflags msg + = ifVerbose dflags 1 (putMsg msg) + +compilationPassMsg :: DynFlags -> String -> IO () +compilationPassMsg dflags msg + = ifVerbose dflags 2 (putMsg msg) + +debugTraceMsg :: DynFlags -> Int -> String -> IO () +debugTraceMsg dflags val msg + = ifVerbose dflags val (putMsg msg) + +GLOBAL_VAR(msgHandler, hPutStrLn stderr, (String -> IO ())) + +setMsgHandler :: (String -> IO ()) -> IO () +setMsgHandler handle_msg = writeIORef msgHandler handle_msg + +putMsg :: String -> IO () +putMsg msg = do h <- readIORef msgHandler; h msg \end{code}