X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=06f08a3601a189612b232f58e57341b1f4ab96b0;hb=27286cf2ce6733cbbf008972c6bea30ea2e562ee;hp=06185bed4e87218cd83c4a70028757c80f016d08;hpb=63489d40bdee972656ff115ab2309b809c0e39fc;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 06185be..06f08a3 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -35,7 +35,7 @@ import Bag import Outputable import UniqSupply import Unique -import LazyUniqFM +import UniqFM import DynFlags import StaticFlags import FastString @@ -115,7 +115,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_dfun_n = dfun_n_var, tcg_keep = keep_var, tcg_doc_hdr = Nothing, - tcg_hpc = False + tcg_hpc = False, + tcg_main = Nothing } ; lcl_env = TcLclEnv { tcl_errs = errs_var, @@ -229,19 +230,19 @@ Command-line flags getDOpts :: TcRnIf gbl lcl DynFlags getDOpts = do { env <- getTopEnv; return (hsc_dflags env) } -doptM :: DynFlag -> TcRnIf gbl lcl Bool +doptM :: DOpt d => d -> TcRnIf gbl lcl Bool doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } -setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setOptM :: DOpt d => d -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setOptM flag = updEnv (\ env@(Env { env_top = top }) -> env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} ) -unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetOptM :: DOpt d => d -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a unsetOptM flag = updEnv (\ env@(Env { env_top = top }) -> env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) -- | Do it flag is true -ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +ifOptM :: DOpt d => d -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () ifOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } @@ -454,6 +455,7 @@ wrapLocSndM fn (L loc a) = return (b, L loc c) \end{code} +Reporting errors \begin{code} getErrsVar :: TcRn (TcRef Messages) @@ -468,47 +470,25 @@ addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg } failWith :: Message -> TcRn a failWith msg = addErr msg >> failM -addLocErr :: Located e -> (e -> Message) -> TcRn () -addLocErr (L loc e) fn = addErrAt loc (fn e) - addErrAt :: SrcSpan -> Message -> TcRn () -addErrAt loc msg = addLongErrAt loc msg empty - -addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () -addLongErrAt loc msg extra - = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; - errs_var <- getErrsVar ; - rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; - let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; - (warns, errs) <- readMutVar errs_var ; - writeMutVar errs_var (warns, errs `snocBag` err) } +-- addErrAt is mainly (exclusively?) used by the renamer, where +-- tidying is not an issue, but it's all lazy so the extra +-- work doesn't matter +addErrAt loc msg = do { ctxt <- getErrCtxt + ; tidy_env <- tcInitTidyEnv + ; err_info <- mkErrInfo tidy_env ctxt + ; addLongErrAt loc msg err_info } addErrs :: [(SrcSpan,Message)] -> TcRn () addErrs msgs = mapM_ add msgs where add (loc,msg) = addErrAt loc msg -addReport :: Message -> TcRn () -addReport msg = do loc <- getSrcSpanM; addReportAt loc msg - -addReportAt :: SrcSpan -> Message -> TcRn () -addReportAt loc msg - = do { errs_var <- getErrsVar ; - rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; - let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ; - (warns, errs) <- readMutVar errs_var ; - writeMutVar errs_var (warns `snocBag` warn, errs) } - addWarn :: Message -> TcRn () -addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) +addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty addWarnAt :: SrcSpan -> Message -> TcRn () -addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) - -addLocWarn :: Located e -> (e -> Message) -> TcRn () -addLocWarn (L loc e) fn = addReportAt loc (fn e) +addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty checkErr :: Bool -> Message -> TcRn () -- Add the error if the bool is False @@ -541,6 +521,38 @@ discardWarnings thing_inside \end{code} +%************************************************************************ +%* * + Shared error message stuff: renamer and typechecker +%* * +%************************************************************************ + +\begin{code} +addReport :: Message -> Message -> TcRn () +addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info + +addReportAt :: SrcSpan -> Message -> Message -> TcRn () +addReportAt loc msg extra_info + = do { errs_var <- getErrsVar ; + rdr_env <- getGlobalRdrEnv ; + dflags <- getDOpts ; + let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) + msg extra_info } ; + (warns, errs) <- readMutVar errs_var ; + writeMutVar errs_var (warns `snocBag` warn, errs) } + +addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () +addLongErrAt loc msg extra + = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; + errs_var <- getErrsVar ; + rdr_env <- getGlobalRdrEnv ; + dflags <- getDOpts ; + let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; + (warns, errs) <- readMutVar errs_var ; + writeMutVar errs_var (warns, errs `snocBag` err) } +\end{code} + + \begin{code} try_m :: TcRn r -> TcRn (Either IOEnvFailure r) -- Does try_m, with a debug-trace on failure @@ -673,8 +685,7 @@ failIfErrsM = ifErrsM failM (return ()) %************************************************************************ %* * - Context management and error message generation - for the type checker + Context management for the type checker %* * %************************************************************************ @@ -719,6 +730,12 @@ setInstCtxt (InstLoc _ src_loc ctxt) thing_inside = setSrcSpan src_loc (setErrCtxt ctxt thing_inside) \end{code} +%************************************************************************ +%* * + Error message generation (type checker) +%* * +%************************************************************************ + The addErrTc functions add an error message, but do not cause failure. The 'M' variants pass a TidyEnv that has already been used to tidy up the message; we then use it to tidy the context messages @@ -765,7 +782,7 @@ addWarnTcM :: (TidyEnv, Message) -> TcM () addWarnTcM (env0, msg) = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo env0 ctxt ; - addReport (vcat [ptext (sLit "Warning:") <+> msg, err_info]) } + addReport (ptext (sLit "Warning:") <+> msg) err_info } warnTc :: Bool -> Message -> TcM () warnTc warn_if_true warn_msg