X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FErrUtils.lhs;fp=ghc%2Fcompiler%2Fmain%2FErrUtils.lhs;h=0000000000000000000000000000000000000000;hb=0065d5ab628975892cea1ec7303f968c3338cbe1;hp=90e5dc87b6a204cdf98fc6d0f42e377df1527cc9;hpb=28a464a75e14cece5db40f2765a29348273ff2d2;p=ghc-hetmet.git diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs deleted file mode 100644 index 90e5dc8..0000000 --- a/ghc/compiler/main/ErrUtils.lhs +++ /dev/null @@ -1,260 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1994-1998 -% -\section[ErrsUtils]{Utilities for error reporting} - -\begin{code} -module ErrUtils ( - Message, mkLocMessage, printError, - Severity(..), - - ErrMsg, WarnMsg, - errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, - Messages, errorsFound, emptyMessages, - mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, - printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, - - ghcExit, - doIfSet, doIfSet_dyn, - 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 ( sortLe, global ) -import Outputable -import qualified Pretty -import SrcLoc ( srcSpanStart, noSrcSpan ) -import DynFlags ( DynFlags(..), DynFlag(..), dopt ) -import StaticFlags ( opt_ErrorSpans ) -import System ( ExitCode(..), exitWith ) -import DATA_IOREF -import IO ( hPutStrLn, stderr ) -import DYNAMIC - - --- ----------------------------------------------------------------------------- --- Basic error messages: just render a message with a source location. - -type Message = SDoc - -data Severity - = SevInfo - | SevWarning - | SevError - | SevFatal - -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 "". - -printError :: SrcSpan -> Message -> IO () -printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle) - - --- ----------------------------------------------------------------------------- --- 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 - --- 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 - --- 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 - -type Messages = (Bag WarnMsg, 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 -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 - where - no_warns = isEmptyBag warns - no_errs = isEmptyBag errs - -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 = sortLe occ'ed_before bag_ls - - occ'ed_before err1 err2 = - 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 - - 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 :: DynFlags -> Int -> IO () -ghcExit dflags val - | val == 0 = exitWith ExitSuccess - | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") - exitWith (ExitFailure val) -\end{code} - -\begin{code} -doIfSet :: Bool -> IO () -> IO () -doIfSet flag action | flag = action - | otherwise = return () - -doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO() -doIfSet_dyn dflags flag action | dopt flag dflags = action - | otherwise = return () -\end{code} - -\begin{code} -dumpIfSet :: Bool -> String -> SDoc -> IO () -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 = printDump (mkDumpDoc hdr doc) - | otherwise = return () - -dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () -dumpIfSet_dyn dflags flag hdr doc - | dopt flag dflags || verbosity dflags >= 4 - = printDump (mkDumpDoc hdr doc) - | otherwise - = return () - -dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO () -dumpIfSet_dyn_or dflags flags hdr doc - | or [dopt flag dflags | flag <- flags] - || verbosity dflags >= 4 - = printDump (mkDumpDoc hdr doc) - | otherwise = return () - -mkDumpDoc hdr doc - = vcat [text "", - line <+> text hdr <+> line, - 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}