Commit 29da2cf3 authored by simonmar's avatar simonmar

[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.
parent 433d69e5
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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.
}}
......
......@@ -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}
......
......@@ -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
......
......@@ -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)
......
......@@ -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 []
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment