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,
%************************************************************************
\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
; 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
mg_binds = ds_binds,
mg_foreign = ds_fords }
- ; return (Just mod_guts)
+ ; return (warns, Just mod_guts)
}}
where
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
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
Message, mkLocMessage, printError,
ErrMsg, WarnMsg,
+ errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
Messages, errorsFound, emptyMessages,
- mkErrMsg, mkWarnMsg,
+ mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
ghcExit,
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
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
| 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
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
\begin{code}
module HscMain (
- HscResult(..), hscMain, newHscEnv
+ HscResult(..), hscMain, newHscEnv, hscBufferFrontEnd
#ifdef GHCI
, hscStmt, hscTcExpr, hscThing,
, compileExpr
import CmdLineOpts
import DriverPhases ( isExtCoreFilename )
-import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass, printError )
+import ErrUtils
import UniqSupply ( mkSplitUniqSupply )
import Outputable
import Module ( Module, ModLocation(..), showModMsg )
import FastString
import Maybes ( expectJust )
+import StringBuffer ( StringBuffer )
+import Bag ( unitBag, emptyBag )
import Monad ( when )
import Maybe ( isJust, fromJust )
\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)
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
-> 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) <-
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 {
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?
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;
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)
}}}
-hscFrontEnd hsc_env location = do {
+hscFileFrontEnd hsc_env msg_act location = do {
-------------------
-- PARSE
-------------------
(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 {
-------------------
-- 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.
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 {
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.
}}
The GhciMode is self-explanatory:
\begin{code}
-data GhciMode = Batch | Interactive | OneShot
+data GhciMode = Batch | Interactive | OneShot | IDE
deriving Eq
\end{code}
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
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 )
\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))
\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)
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 )
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)
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 }
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) }
\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 []
\begin{code}
module StringBuffer
(
- StringBuffer,
+ StringBuffer(..),
+ -- non-abstract for vs/HaskellService
-- * Creation/destruction
hGetStringBuffer, -- :: FilePath -> IO StringBuffer
projects / ghc-hetmet.git / commitdiff