X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=d4e8e8fc73e83614074228eef8bf024169a3974b;hb=81466110ff8104ca60e20d617bab83f6f78f0ec2;hp=42cb31474d24fe5462ea499f9d0a81f93ff65773;hpb=b1ab4b8a607addc4d097588db5761313c996a41f;p=ghc-hetmet.git diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 42cb314..d4e8e8f 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -8,15 +8,17 @@ module ErrUtils ( Message, mkLocMessage, printError, Severity(..), - ErrMsg, WarnMsg, + ErrMsg, WarnMsg, throwErrMsg, handleErrMsg, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, Messages, errorsFound, emptyMessages, mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, + handleFlagWarnings, ghcExit, doIfSet, doIfSet_dyn, - dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, + dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, + mkDumpDoc, dumpSDoc, -- * Messages during compilation putMsg, @@ -37,9 +39,12 @@ import SrcLoc ( srcSpanStart, noSrcSpan ) import DynFlags ( DynFlags(..), DynFlag(..), dopt ) import StaticFlags ( opt_ErrorSpans ) +import Control.Monad import System.Exit ( ExitCode(..), exitWith ) import Data.Dynamic - +import Data.List +import System.IO +import Exception -- ----------------------------------------------------------------------------- -- Basic error messages: just render a message with a source location. @@ -77,16 +82,33 @@ 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 +#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 -#if __GLASGOW_HASKELL__ < 603 - typeOf _ = mkAppTy errMsgTc [] -#else typeOf _ = mkTyConApp errMsgTc [] -#endif type WarnMsg = ErrMsg @@ -124,10 +146,13 @@ errorsFound dflags (warns, 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 + | 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 @@ -136,7 +161,7 @@ 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, + | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, errMsgExtraInfo = e, errMsgContext = unqual } <- sorted_errs ] @@ -154,7 +179,7 @@ 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, + | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, errMsgExtraInfo = e, errMsgContext = unqual } <- sorted_errs ] @@ -167,17 +192,29 @@ printBagOfWarnings dflags bag_of_warns LT -> True EQ -> True GT -> False -\end{code} -\begin{code} +handleFlagWarnings :: DynFlags -> [String] -> IO () +handleFlagWarnings dflags warns + = when (dopt Opt_WarnDeprecatedFlags dflags) + (handleFlagWarnings' dflags warns) + +handleFlagWarnings' :: DynFlags -> [String] -> IO () +handleFlagWarnings' _ [] = return () +handleFlagWarnings' dflags warns + = do -- It would be nicer if warns :: [Message], but that has circular + -- import problems. + let warns' = map text warns + mapM_ (log_action dflags SevWarning noSrcSpan defaultUserStyle) warns' + when (dopt Opt_WarnIsError dflags) $ + do errorMsg dflags $ text "\nFailing due to -Werror.\n" + exitWith (ExitFailure 1) + 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 () @@ -185,25 +222,32 @@ doIfSet flag action | flag = action doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO() doIfSet_dyn dflags flag action | dopt flag dflags = action | otherwise = return () -\end{code} -\begin{code} +-- ----------------------------------------------------------------------------- +-- Dumping + dumpIfSet :: Bool -> String -> SDoc -> IO () 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 - | dopt flag dflags - || verbosity dflags >= 4 - || dopt Opt_D_verbose_core2core dflags = printDump (mkDumpDoc hdr doc) - | otherwise = return () + = 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 - = printDump (mkDumpDoc hdr doc) + = dumpSDoc dflags flag hdr doc | otherwise = return () @@ -214,6 +258,7 @@ dumpIfSet_dyn_or dflags flags hdr doc = printDump (mkDumpDoc hdr doc) | otherwise = return () +mkDumpDoc :: String -> SDoc -> SDoc mkDumpDoc hdr doc = vcat [text "", line <+> text hdr <+> line, @@ -222,6 +267,64 @@ mkDumpDoc hdr doc where line = text (replicate 20 '=') + +-- | Write out a dump. +-- If --dump-to-file is set then this goes to a file. +-- 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) + + +-- | Choose where to put a dump file based on DynFlags +-- +chooseDumpFile :: DynFlags -> DynFlag -> Maybe String +chooseDumpFile dflags dflag + + -- dump file location is being forced + -- by the --ddump-file-prefix flag. + | dumpToFile + , Just prefix <- dumpPrefixForce dflags + = Just $ prefix ++ (beautifyDumpName dflag) + + -- dump file location chosen by DriverPipeline.runPipeline + | dumpToFile + , Just prefix <- dumpPrefix dflags + = Just $ prefix ++ (beautifyDumpName dflag) + + -- we haven't got a place to put a dump file. + | otherwise + = Nothing + + where dumpToFile = dopt Opt_DumpToFile dflags + + +-- | Build a nice file name from name of a DynFlag constructor +beautifyDumpName :: DynFlag -> String +beautifyDumpName dflag + = let str = show dflag + cut = if isPrefixOf "Opt_D_" str + then drop 6 str + else str + dash = map (\c -> case c of + '_' -> '-' + _ -> c) + cut + in dash + + -- ----------------------------------------------------------------------------- -- Outputting messages from the compiler @@ -255,4 +358,5 @@ showPass dflags what debugTraceMsg :: DynFlags -> Int -> Message -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) + \end{code}