diff options
Diffstat (limited to 'compiler/main/ErrUtils.lhs')
| -rw-r--r-- | compiler/main/ErrUtils.lhs | 119 |
1 files changed, 71 insertions, 48 deletions
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 6ba9df436c..daa66f9d2f 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -9,7 +9,7 @@ module ErrUtils ( ErrMsg, WarnMsg, Severity(..), Messages, ErrorMessages, WarningMessages, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, - MsgDoc, mkLocMessage, printError, pprMessageBag, pprErrMsgBag, + MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc, pprLocErrMsg, makeIntoWarning, errorsFound, emptyMessages, @@ -25,27 +25,32 @@ module ErrUtils ( -- * Messages during compilation putMsg, putMsgWith, errorMsg, - fatalErrorMsg, fatalErrorMsg', + fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'', compilationProgressMsg, showPass, debugTraceMsg, + + prettyPrintGhcErrors, ) where #include "HsVersions.h" import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) -import Util +import Exception import Outputable +import Panic import FastString import SrcLoc import DynFlags import StaticFlags ( opt_ErrorSpans ) +import System.Directory import System.Exit ( ExitCode(..), exitWith ) import System.FilePath import Data.List import qualified Data.Set as Set import Data.IORef +import Data.Ord import Control.Monad import System.IO @@ -59,7 +64,8 @@ type ErrorMessages = Bag ErrMsg data ErrMsg = ErrMsg { errMsgSpans :: [SrcSpan], errMsgContext :: PrintUnqualified, - errMsgShortDoc :: MsgDoc, + errMsgShortDoc :: MsgDoc, -- errMsgShort* should always + errMsgShortString :: String, -- contain the same text errMsgExtraInfo :: MsgDoc, errMsgSeverity :: Severity } @@ -70,13 +76,14 @@ type MsgDoc = SDoc data Severity = SevOutput + | SevDump | SevInfo | SevWarning | SevError | SevFatal instance Show ErrMsg where - show em = showSDoc (errMsgShortDoc em) + show em = errMsgShortString em pprMessageBag :: Bag MsgDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) @@ -95,41 +102,40 @@ mkLocMessage severity locn msg -- For warnings, print Foo.hs:34: Warning: -- <the warning message> -printError :: SrcSpan -> MsgDoc -> IO () -printError span msg = printErrs (mkLocMessage SevError span msg) defaultErrStyle - makeIntoWarning :: ErrMsg -> ErrMsg makeIntoWarning err = err { errMsgSeverity = SevWarning } -- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. -mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg -mk_err_msg sev locn print_unqual msg extra +mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg +mk_err_msg dflags sev locn print_unqual msg extra = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual - , errMsgShortDoc = msg, errMsgExtraInfo = extra + , errMsgShortDoc = msg , errMsgShortString = showSDoc dflags msg + , errMsgExtraInfo = extra , errMsgSeverity = sev } -mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg +mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg -- A long (multi-line) error message -mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg +mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg -- A short (one-line) error message -mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> MsgDoc -> ErrMsg +mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg -- Variant that doesn't care about qualified/unqualified names -mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual msg extra -mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual msg empty -mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify msg empty -mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual msg extra -mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual msg empty -mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify msg empty +mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual msg extra +mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual msg empty +mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify msg empty +mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual msg extra +mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual msg empty +mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify msg empty ---------------- emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) -warnIsErrorMsg :: ErrMsg -warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.") +warnIsErrorMsg :: DynFlags -> ErrMsg +warnIsErrorMsg dflags + = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.") errorsFound :: DynFlags -> Messages -> Bool errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) @@ -140,26 +146,31 @@ printBagOfErrors dflags bag_of_errors pprErrMsgBag :: Bag ErrMsg -> [SDoc] pprErrMsgBag bag - = [ let style = mkErrStyle unqual + = [ sdocWithDynFlags $ \dflags -> + let style = mkErrStyle dflags unqual in withPprStyle style (d $$ e) | ErrMsg { errMsgShortDoc = d, errMsgExtraInfo = e, errMsgContext = unqual } <- sortMsgBag bag ] +pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc] +pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag bag ] + pprLocErrMsg :: ErrMsg -> SDoc pprLocErrMsg (ErrMsg { errMsgSpans = spans , errMsgShortDoc = d , errMsgExtraInfo = e , errMsgSeverity = sev , errMsgContext = unqual }) - = withPprStyle (mkErrStyle unqual) (mkLocMessage sev s (d $$ e)) + = sdocWithDynFlags $ \dflags -> + withPprStyle (mkErrStyle dflags unqual) (mkLocMessage sev s (d $$ e)) where (s : _) = spans -- Should be non-empty printMsgBag :: DynFlags -> Bag ErrMsg -> IO () printMsgBag dflags bag - = sequence_ [ let style = mkErrStyle unqual - in log_action dflags sev s style (d $$ e) + = sequence_ [ let style = mkErrStyle dflags unqual + in log_action dflags dflags sev s style (d $$ e) | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, errMsgSeverity = sev, @@ -167,13 +178,8 @@ printMsgBag dflags bag errMsgContext = unqual } <- sortMsgBag bag ] sortMsgBag :: Bag ErrMsg -> [ErrMsg] -sortMsgBag bag = sortLe srcOrder $ bagToList bag - where - srcOrder err1 err2 = - case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of - LT -> True - EQ -> True - GT -> False +sortMsgBag bag = sortBy (comparing (head . errMsgSpans)) $ bagToList bag + -- TODO: Why "head ."? Why not compare the whole list? ghcExit :: DynFlags -> Int -> IO () ghcExit dflags val @@ -192,10 +198,10 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action -- ----------------------------------------------------------------------------- -- Dumping -dumpIfSet :: Bool -> String -> SDoc -> IO () -dumpIfSet flag hdr doc +dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () +dumpIfSet dflags flag hdr doc | not flag = return () - | otherwise = printDump (mkDumpDoc hdr doc) + | otherwise = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc) dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc @@ -239,14 +245,14 @@ dumpSDoc dflags dflag hdr doc mode = if append then AppendMode else WriteMode when (not append) $ writeIORef gdref (Set.insert fileName gd) - createDirectoryHierarchy (takeDirectory fileName) + createDirectoryIfMissing True (takeDirectory fileName) handle <- openFile fileName mode - hPrintDump handle doc + hPrintDump dflags handle doc hClose handle -- write the dump to stdout Nothing - -> printDump (mkDumpDoc hdr doc) + -> log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc) -- | Choose where to put a dump file based on DynFlags @@ -299,33 +305,50 @@ ifVerbose dflags val act | otherwise = return () putMsg :: DynFlags -> MsgDoc -> IO () -putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg +putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () putMsgWith dflags print_unqual msg - = log_action dflags SevInfo noSrcSpan sty msg + = log_action dflags dflags SevInfo noSrcSpan sty msg where sty = mkUserStyle print_unqual AllTheWay errorMsg :: DynFlags -> MsgDoc -> IO () -errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg +errorMsg dflags msg = + log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg fatalErrorMsg :: DynFlags -> MsgDoc -> IO () -fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg +fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg + +fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO () +fatalErrorMsg' la dflags msg = + la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg -fatalErrorMsg' :: LogAction -> MsgDoc -> IO () -fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg +fatalErrorMsg'' :: FatalMessager -> String -> IO () +fatalErrorMsg'' fm msg = fm msg compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg dflags msg - = ifVerbose dflags 1 (log_action dflags SevOutput noSrcSpan defaultUserStyle (text msg)) + = ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg)) showPass :: DynFlags -> String -> IO () showPass dflags what - = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) + = ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () debugTraceMsg dflags val msg - = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) + = ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg) + +prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a +prettyPrintGhcErrors dflags + = ghandle $ \e -> case e of + PprPanic str doc -> + pprDebugAndThen dflags panic str doc + PprSorry str doc -> + pprDebugAndThen dflags sorry str doc + PprProgramError str doc -> + pprDebugAndThen dflags pgmError str doc + _ -> + throw e \end{code} |