X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=a0a9f0e3b39369000c92402de5aacec901ee3d5e;hp=66ade906fb0c4398a9c9a0f685c772b3280d6d5b;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=f96194794bf099020706c3816d1a5678b40addbb diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 66ade90..a0a9f0e 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -5,23 +5,24 @@ \begin{code} module ErrUtils ( - Message, mkLocMessage, printError, + Message, mkLocMessage, printError, pprMessageBag, Severity(..), ErrMsg, WarnMsg, ErrorMessages, WarningMessages, + errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, Messages, errorsFound, emptyMessages, mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, - printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, + 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, @@ -38,9 +39,11 @@ import SrcLoc import DynFlags ( DynFlags(..), DynFlag(..), dopt ) import StaticFlags ( opt_ErrorSpans ) -import Control.Monad import System.Exit ( ExitCode(..), exitWith ) import Data.List +import qualified Data.Set as Set +import Data.IORef +import Control.Monad import System.IO -- ----------------------------------------------------------------------------- @@ -48,8 +51,12 @@ import System.IO type Message = SDoc +pprMessageBag :: Bag Message -> SDoc +pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) + data Severity - = SevInfo + = SevOutput + | SevInfo | SevWarning | SevError | SevFatal @@ -63,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 -- ----------------------------------------------------------------------------- @@ -121,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 = @@ -201,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 @@ -222,11 +190,11 @@ 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 @@ -243,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 @@ -311,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 @@ -319,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