X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=a0a9f0e3b39369000c92402de5aacec901ee3d5e;hp=a0325bf8080c29d3f1ff60ba3f5bffec4ed464e6;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=850a5149aa0449276fe038568aa9ce555d3fc186 diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index a0325bf..a0a9f0e 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -5,25 +5,24 @@ \begin{code} module ErrUtils ( - Message, mkLocMessage, printError, + Message, mkLocMessage, printError, pprMessageBag, Severity(..), - ErrMsg, WarnMsg, throwErrMsg, handleErrMsg, - ErrorMessages, WarningMessages, - errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, + ErrMsg, WarnMsg, + ErrorMessages, WarningMessages, + errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, Messages, errorsFound, emptyMessages, mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, - printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, - handleFlagWarnings, - warnIsErrorMsg, + printBagOfErrors, printBagOfWarnings, + warnIsErrorMsg, mkLongWarnMsg, ghcExit, doIfSet, doIfSet_dyn, - dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, + dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, dumpSDoc, -- * Messages during compilation - putMsg, + putMsg, putMsgWith, errorMsg, fatalErrorMsg, compilationProgressMsg, @@ -40,20 +39,24 @@ 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 qualified Data.Set as Set +import Data.IORef +import Control.Monad import System.IO -import Exception -- ----------------------------------------------------------------------------- -- Basic error messages: just render a message with a source location. type Message = SDoc +pprMessageBag :: Bag Message -> SDoc +pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) + data Severity - = SevInfo + = SevOutput + | SevInfo | SevWarning | SevError | SevFatal @@ -67,7 +70,8 @@ mkLocMessage locn msg -- would look strange. Better to say explicitly "". printError :: SrcSpan -> Message -> IO () -printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle) +printError span msg = + printErrs (mkLocMessage span msg) defaultErrStyle -- ----------------------------------------------------------------------------- @@ -80,59 +84,38 @@ 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 - -#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 - typeOf _ = mkTyConApp errMsgTc [] - 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 + = 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 @@ -146,56 +129,29 @@ emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) warnIsErrorMsg :: ErrMsg -warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.\n") +warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.") errorsFound :: DynFlags -> Messages -> Bool --- The dyn-flags are used to see if the user has specified --- -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 = 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 +errorsFound _dflags (_warns, errs) = not (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:_, - errMsgShortDoc = d, - errMsgExtraInfo = e, - errMsgContext = unqual } <- sorted_errs ] - where - bag_ls = bagToList bag_of_errors - sorted_errs = sortLe occ'ed_before bag_ls +printBagOfErrors dflags bag_of_errors = + printMsgBag dflags bag_of_errors SevError - occ'ed_before err1 err2 = - case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of - LT -> True - EQ -> True - GT -> False +printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO () +printBagOfWarnings dflags bag_of_warns = + printMsgBag dflags bag_of_warns SevWarning -printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO () -printBagOfWarnings dflags bag_of_warns +printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO () +printMsgBag dflags bag sev = sequence_ [ let style = mkErrStyle unqual - in log_action dflags SevWarning s style (d $$ e) + in log_action dflags sev s style (d $$ e) | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, errMsgExtraInfo = e, errMsgContext = unqual } <- sorted_errs ] where - bag_ls = bagToList bag_of_warns + bag_ls = bagToList bag sorted_errs = sortLe occ'ed_before bag_ls occ'ed_before err1 err2 = @@ -204,25 +160,6 @@ 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 | val == 0 = exitWith ExitSuccess @@ -245,19 +182,6 @@ 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 - = dumpIf_core (dopt flag dflags) dflags flag hdr doc - dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc | dopt flag dflags || verbosity dflags >= 4 @@ -266,18 +190,18 @@ dumpIfSet_dyn dflags flag hdr doc = 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 () +dumpIfSet_dyn_or _ [] _ _ = return () +dumpIfSet_dyn_or dflags (flag : flags) hdr doc + = if dopt flag dflags || verbosity dflags >= 4 + then dumpSDoc dflags flag hdr doc + else dumpIfSet_dyn_or dflags flags hdr doc mkDumpDoc :: String -> SDoc -> SDoc mkDumpDoc hdr doc - = vcat [text "", + = vcat [blankLine, line <+> text hdr <+> line, doc, - text ""] + blankLine] where line = text (replicate 20 '=') @@ -287,19 +211,26 @@ mkDumpDoc hdr doc -- otherwise emit to stdout. 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 - hClose handle - - -- write the dump to stdout - Nothing - -> do printDump (mkDumpDoc 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 + let gdref = generatedDumps dflags + gd <- readIORef gdref + let append = Set.member fileName gd + mode = if append then AppendMode else WriteMode + when (not append) $ + writeIORef gdref (Set.insert fileName gd) + handle <- openFile fileName mode + hPrintDump handle doc + hClose handle + + -- write the dump to stdout + Nothing + -> printDump (mkDumpDoc hdr doc) -- | Choose where to put a dump file based on DynFlags @@ -355,6 +286,12 @@ ifVerbose dflags val act putMsg :: DynFlags -> Message -> IO () putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg +putMsgWith :: DynFlags -> PrintUnqualified -> Message -> IO () +putMsgWith dflags print_unqual msg + = log_action dflags SevInfo noSrcSpan sty msg + where + sty = mkUserStyle print_unqual AllTheWay + errorMsg :: DynFlags -> Message -> IO () errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg @@ -363,7 +300,7 @@ fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg dflags msg - = ifVerbose dflags 1 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text msg)) + = ifVerbose dflags 1 (log_action dflags SevOutput noSrcSpan defaultUserStyle (text msg)) showPass :: DynFlags -> String -> IO () showPass dflags what