From 29da2cf3011c292bc4261601aff85afb13e24d54 Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 23 Jan 2004 13:55:30 +0000 Subject: [PATCH] [project @ 2004-01-23 13:55:28 by simonmar] Some small steps in the direction of making GHC useable as a library: - The ErrMsg type is now richer: we keep the location info and the PrintUnqualified separate until the message is printed out, and messages have a short summary and "extra info", where the extra info is used for things like the context info in the typechecker (stuff that you don't normally want to see in a more visual setting, where the context is obvious because you're looking at the code). - hscMain now takes an extra argument of type (Messages -> IO ()), which says what to do with the error messages. In normal usage, we just pass ErrUtils.printErrorsAndWarnings, but eg. a development environment will want to do something different. The direction we need to head in is for hscMain to *never* do any output to stdout/stderr except via abstractions like this. --- ghc/compiler/deSugar/Desugar.lhs | 14 +++--- ghc/compiler/main/DriverPipeline.hs | 4 +- ghc/compiler/main/ErrUtils.lhs | 59 ++++++++++++++++++------ ghc/compiler/main/HscMain.lhs | 80 +++++++++++++++++++++++---------- ghc/compiler/main/HscTypes.lhs | 2 +- ghc/compiler/rename/RnBinds.lhs | 2 + ghc/compiler/typecheck/TcRnDriver.lhs | 6 +-- ghc/compiler/typecheck/TcRnMonad.lhs | 19 ++++---- ghc/compiler/utils/StringBuffer.lhs | 3 +- 9 files changed, 128 insertions(+), 61 deletions(-) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 2deb343..599c759 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -33,7 +33,7 @@ import RdrName ( GlobalRdrEnv ) import NameSet import VarEnv import VarSet -import Bag ( isEmptyBag, mapBag, emptyBag, bagToList ) +import Bag ( Bag, isEmptyBag, mapBag, emptyBag, bagToList ) import CoreLint ( showPass, endPass ) import CoreFVs ( ruleRhsFreeVars ) import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, @@ -52,7 +52,7 @@ import FastString %************************************************************************ \begin{code} -deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts) +deSugar :: HscEnv -> TcGblEnv -> IO (Bag WarnMsg, Maybe ModGuts) -- Can modify PCS by faulting in more declarations deSugar hsc_env @@ -75,15 +75,11 @@ deSugar hsc_env ; let { (ds_binds, ds_rules, ds_fords) = results ; warns = mapBag mk_warn warnings - ; warn_doc = pprBagOfWarnings warns } - - -- Display any warnings - ; doIfSet (not (isEmptyBag warnings)) - (printErrs warn_doc) + } -- If warnings are considered errors, leave. ; if errorsFound dflags (warns, emptyBag) - then return Nothing + then return (warns, Nothing) else do -- Lint result if necessary @@ -115,7 +111,7 @@ deSugar hsc_env mg_binds = ds_binds, mg_foreign = ds_fords } - ; return (Just mod_guts) + ; return (warns, Just mod_guts) }} where diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index d1d5c3b..d4cb66a 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -158,7 +158,7 @@ compile hsc_env this_mod location hsc_env' = hsc_env { hsc_dflags = dyn_flags' } -- run the compiler - hsc_result <- hscMain hsc_env' this_mod location + hsc_result <- hscMain hsc_env' printErrorsAndWarnings this_mod location source_unchanged' have_object old_iface case hsc_result of @@ -630,7 +630,7 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do hsc_env <- newHscEnv OneShot dyn_flags' -- run the compiler! - result <- hscMain hsc_env mod + result <- hscMain hsc_env printErrorsAndWarnings mod location{ ml_hspp_file=Just input_fn } source_unchanged False diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index ecad689..358c7ab 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -8,8 +8,9 @@ module ErrUtils ( Message, mkLocMessage, printError, ErrMsg, WarnMsg, + errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, Messages, errorsFound, emptyMessages, - mkErrMsg, mkWarnMsg, + mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings, ghcExit, @@ -32,11 +33,11 @@ import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt, import List ( replicate ) import System ( ExitCode(..), exitWith ) import IO ( hPutStr, stderr, stdout ) -\end{code} -Basic error messages: just render a message with a source location. -\begin{code} +-- ----------------------------------------------------------------------------- +-- Basic error messages: just render a message with a source location. + type Message = SDoc mkLocMessage :: SrcSpan -> Message -> Message @@ -49,27 +50,52 @@ mkLocMessage locn msg printError :: SrcSpan -> Message -> IO () printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle) -\end{code} -Collecting up messages for later ordering and printing. -\begin{code} -data ErrMsg = ErrMsg SrcSpan Pretty.Doc +-- ----------------------------------------------------------------------------- +-- 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 type WarnMsg = ErrMsg --- These two are used heavily by renamer/typechecker. --- Be refined about qualification, return an 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 (mkLocMessage locn msg $ mkErrStyle print_unqual) + = 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 + +-- A long (multi-line) error message, with context to tell us whether +-- to qualify names in the message or not. +mkLongMultiLocErrMsg :: [SrcSpan] -> PrintUnqualified -> Message -> Message -> ErrMsg +mkLongMultiLocErrMsg locns print_unqual msg extra + = ErrMsg locns print_unqual msg extra mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg mkWarnMsg = mkErrMsg +mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> WarnMsg +mkLongWarnMsg = mkLongErrMsg + type Messages = (Bag WarnMsg, Bag ErrMsg) emptyMessages :: Messages @@ -83,10 +109,10 @@ errorsFound dflags (warns, errs) | otherwise = not (isEmptyBag errs) printErrorsAndWarnings :: Messages -> IO () - -- Don't print any warnings if there are errors printErrorsAndWarnings (warns, errs) | no_errs && no_warns = return () | no_errs = printErrs (pprBagOfWarnings warns) + -- Don't print any warnings if there are errors | otherwise = printErrs (pprBagOfErrors errs) where no_warns = isEmptyBag warns @@ -94,12 +120,17 @@ printErrorsAndWarnings (warns, errs) pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc pprBagOfErrors bag_of_errors - = Pretty.vcat [Pretty.text "" Pretty.$$ e | ErrMsg _ e <- sorted_errs ] + = Pretty.vcat [ let style = mkErrStyle unqual in + Pretty.text "" Pretty.$$ d style Pretty.$$ e style + | ErrMsg { errMsgShortDoc = d, + errMsgExtraInfo = e, + errMsgContext = unqual } <- sorted_errs ] where bag_ls = bagToList bag_of_errors sorted_errs = sortLt occ'ed_before bag_ls - occ'ed_before (ErrMsg l1 _) (ErrMsg l2 _) = LT == compare l1 l2 + occ'ed_before err1 err2 = + LT == compare (head (errMsgSpans err1)) (head (errMsgSpans err1)) pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 0c7bb28..395ab86 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -6,7 +6,7 @@ \begin{code} module HscMain ( - HscResult(..), hscMain, newHscEnv + HscResult(..), hscMain, newHscEnv, hscBufferFrontEnd #ifdef GHCI , hscStmt, hscTcExpr, hscThing, , compileExpr @@ -61,7 +61,7 @@ import CodeOutput ( codeOutput ) import CmdLineOpts import DriverPhases ( isExtCoreFilename ) -import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass, printError ) +import ErrUtils import UniqSupply ( mkSplitUniqSupply ) import Outputable @@ -73,6 +73,8 @@ import ParserCoreUtils import Module ( Module, ModLocation(..), showModMsg ) import FastString import Maybes ( expectJust ) +import StringBuffer ( StringBuffer ) +import Bag ( unitBag, emptyBag ) import Monad ( when ) import Maybe ( isJust, fromJust ) @@ -119,7 +121,10 @@ knownKeyNames = map getName wiredInThings \begin{code} data HscResult -- Compilation failed - = HscFail + = HscFail + + -- In IDE mode: we just do the static/dynamic checks + | HscChecked -- Concluded that it wasn't necessary | HscNoRecomp ModDetails -- new details (HomeSymbolTable additions) @@ -133,11 +138,16 @@ data HscResult Bool -- stub_c exists (Maybe CompiledByteCode) + +-- What to do when we have compiler error or warning messages +type MessageAction = Messages -> IO () + -- no errors or warnings; the individual passes -- (parse/rename/typecheck) print messages themselves hscMain :: HscEnv + -> MessageAction -- what to do with errors/warnings -> Module -> ModLocation -- location info -> Bool -- True <=> source unchanged @@ -145,7 +155,7 @@ hscMain -> Maybe ModIface -- old interface, if available -> IO HscResult -hscMain hsc_env mod location +hscMain hsc_env msg_act mod location source_unchanged have_object maybe_old_iface = do { (recomp_reqd, maybe_checked_iface) <- @@ -158,13 +168,13 @@ hscMain hsc_env mod location what_next | recomp_reqd || no_old_iface = hscRecomp | otherwise = hscNoRecomp - ; what_next hsc_env have_object + ; what_next hsc_env msg_act have_object mod location maybe_checked_iface } -- hscNoRecomp definitely expects to have the old interface available -hscNoRecomp hsc_env have_object +hscNoRecomp hsc_env msg_act have_object mod location (Just old_iface) | hsc_mode hsc_env == OneShot = do { @@ -188,7 +198,7 @@ hscNoRecomp hsc_env have_object return (HscNoRecomp new_details old_iface) } -hscRecomp hsc_env have_object +hscRecomp hsc_env msg_act have_object mod location maybe_checked_iface = do { -- what target are we shooting for? @@ -203,9 +213,9 @@ hscRecomp hsc_env have_object showModMsg (not toInterp) mod location); ; front_res <- if toCore then - hscCoreFrontEnd hsc_env location + hscCoreFrontEnd hsc_env msg_act location else - hscFrontEnd hsc_env location + hscFileFrontEnd hsc_env msg_act location ; case front_res of Left flure -> return flure; @@ -309,20 +319,21 @@ hscRecomp hsc_env have_object maybe_bcos) }} -hscCoreFrontEnd hsc_env location = do { +hscCoreFrontEnd hsc_env msg_act location = do { ------------------- -- PARSE ------------------- ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location)) ; case parseCore inp 1 of - FailP s -> hPutStrLn stderr s >> return (Left HscFail); + FailP s -> hPutStrLn stderr s >> return (Left HscFail) OkP rdr_module -> do { ------------------- -- RENAME and TYPECHECK ------------------- - ; maybe_tc_result <- _scc_ "TypeCheck" + ; (tc_msgs, maybe_tc_result) <- _scc_ "TypeCheck" tcRnExtCore hsc_env rdr_module + ; msg_act tc_msgs ; case maybe_tc_result of { Nothing -> return (Left HscFail); Just mod_guts -> return (Right mod_guts) @@ -330,7 +341,7 @@ hscCoreFrontEnd hsc_env location = do { }}} -hscFrontEnd hsc_env location = do { +hscFileFrontEnd hsc_env msg_act location = do { ------------------- -- PARSE ------------------- @@ -338,14 +349,38 @@ hscFrontEnd hsc_env location = do { (expectJust "hscFrontEnd:hspp" (ml_hspp_file location)) ; case maybe_parsed of { - Nothing -> return (Left HscFail); - Just rdr_module -> do { - + Left err -> do { msg_act (unitBag err, emptyBag) ; + ; return (Left HscFail) ; + }; + Right rdr_module -> hscFrontEnd hsc_env msg_act rdr_module + }} + +-- Perform static/dynamic checks on the source code in a StringBuffer +-- This is a temporary solution: it'll read in interface files lazilly, whereas +-- we probably want to use the compilation manager to load in all the modules +-- in a project. +hscBufferFrontEnd :: HscEnv -> StringBuffer -> MessageAction -> IO HscResult +hscBufferFrontEnd hsc_env buffer msg_act = do + let loc = mkSrcLoc (mkFastString "*edit*") 1 0 + case unP parseModule (mkPState buffer loc (hsc_dflags hsc_env)) of + PFailed span err -> do + msg_act (emptyBag, unitBag (mkPlainErrMsg span err)) + return HscFail + POk _ rdr_module -> do + r <- hscFrontEnd hsc_env msg_act rdr_module + case r of + Left r -> return r + Right _ -> return HscChecked + + + +hscFrontEnd hsc_env msg_act rdr_module = do { ------------------- -- RENAME and TYPECHECK ------------------- - ; maybe_tc_result <- _scc_ "Typecheck-Rename" + ; (tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename" tcRnModule hsc_env rdr_module + ; msg_act tc_msgs ; case maybe_tc_result of { Nothing -> return (Left HscFail); Just tc_result -> do { @@ -353,13 +388,13 @@ hscFrontEnd hsc_env location = do { ------------------- -- DESUGAR ------------------- - ; maybe_ds_result <- _scc_ "DeSugar" + ; (warns, maybe_ds_result) <- _scc_ "DeSugar" deSugar hsc_env tc_result + ; msg_act (warns, emptyBag) ; case maybe_ds_result of Nothing -> return (Left HscFail); Just ds_result -> return (Right ds_result); - }}}}} - + }}} hscBackEnd dflags ModGuts{ -- This is the last use of the ModGuts in a compilation. @@ -424,8 +459,7 @@ myParseModule dflags src_filename case unP parseModule (mkPState buf loc dflags) of { - PFailed span err -> do { printError span err ; - return Nothing }; + PFailed span err -> return (Left (mkPlainErrMsg span err)); POk _ rdr_module -> do { @@ -434,7 +468,7 @@ myParseModule dflags src_filename dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" (ppSourceStats False rdr_module) ; - return (Just rdr_module) + return (Right rdr_module) -- ToDo: free the string buffer later. }} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index b35e096..20e2fb1 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -139,7 +139,7 @@ hscEPS hsc_env = readIORef (hsc_EPS hsc_env) The GhciMode is self-explanatory: \begin{code} -data GhciMode = Batch | Interactive | OneShot +data GhciMode = Batch | Interactive | OneShot | IDE deriving Eq \end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index ed835ca..843f28e 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -43,6 +43,8 @@ import Bag import Outputable import Monad ( foldM ) + +import SrcLoc (getLoc) -- tmp \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 227d572..8df2efc 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -49,7 +49,7 @@ import RnEnv ( lookupSrcOcc_maybe ) import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) import PprCore ( pprIdRules, pprCoreBindings ) import CoreSyn ( IdCoreRule, bindersOfBinds ) -import ErrUtils ( mkDumpDoc, showPass ) +import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts ) @@ -128,7 +128,7 @@ import Maybe ( isJust ) \begin{code} tcRnModule :: HscEnv -> Located (HsModule RdrName) - -> IO (Maybe TcGblEnv) + -> IO (Messages, Maybe TcGblEnv) tcRnModule hsc_env (L loc (HsModule maybe_mod exports import_decls local_decls mod_deprec)) @@ -499,7 +499,7 @@ setInteractiveContext icxt thing_inside \begin{code} tcRnExtCore :: HscEnv -> HsExtCore RdrName - -> IO (Maybe ModGuts) + -> IO (Messages, Maybe ModGuts) -- Nothing => some error occurred tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 39313ec..350aca0 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -27,7 +27,8 @@ import InstEnv ( InstEnv, emptyInstEnv, extendInstEnv ) import VarSet ( emptyVarSet ) import VarEnv ( TidyEnv, emptyTidyEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, - mkErrMsg, mkWarnMsg, printErrorsAndWarnings, mkLocMessage ) + mkErrMsg, mkWarnMsg, printErrorsAndWarnings, + mkLocMessage, mkLongErrMsg ) import SrcLoc ( mkGeneralSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) import NameSet ( emptyDUs, emptyNameSet ) @@ -64,7 +65,7 @@ ioToTcRn = ioToIOEnv initTc :: HscEnv -> Module -> TcM r - -> IO (Maybe r) + -> IO (Messages, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) @@ -114,15 +115,14 @@ initTc hsc_env mod do_this Right res -> return (Just res) Left _ -> return Nothing } ; - -- Print any error messages + -- Collect any error messages msgs <- readIORef errs_var ; - printErrorsAndWarnings msgs ; let { dflags = hsc_dflags hsc_env ; final_res | errorsFound dflags msgs = Nothing | otherwise = maybe_res } ; - return final_res + return (msgs, final_res) } where init_imports = emptyImportAvails { imp_qual = unitModuleEnv mod emptyAvailEnv } @@ -398,10 +398,13 @@ addLocErr :: Located e -> (e -> Message) -> TcRn () addLocErr (L loc e) fn = addErrAt loc (fn e) addErrAt :: SrcSpan -> Message -> TcRn () -addErrAt loc msg +addErrAt loc msg = addLongErrAt loc msg empty + +addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () +addLongErrAt loc msg extra = do { errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { err = mkErrMsg loc (unQualInScope rdr_env) msg } ; + let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } @@ -651,7 +654,7 @@ warnTc warn_if_true warn_msg \begin{code} add_err_tcm tidy_env err_msg loc ctxt = do { ctxt_msgs <- do_ctxt tidy_env ctxt ; - addErrAt loc (vcat (err_msg : ctxt_to_use ctxt_msgs)) } + addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) } do_ctxt tidy_env [] = return [] diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs index 1a7020b..7c61b5b 100644 --- a/ghc/compiler/utils/StringBuffer.lhs +++ b/ghc/compiler/utils/StringBuffer.lhs @@ -8,7 +8,8 @@ Buffers for scanning string input stored in external arrays. \begin{code} module StringBuffer ( - StringBuffer, + StringBuffer(..), + -- non-abstract for vs/HaskellService -- * Creation/destruction hGetStringBuffer, -- :: FilePath -> IO StringBuffer -- 1.7.10.4