X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=835752e0e0b21a29f700dc1daa1c5194291b8d3a;hb=e393bb3a7dd22fc27e753af3f18356790e65f73c;hp=c138fc65a3465c386a1023623b0266af832ba848;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index c138fc6..835752e 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -14,7 +14,7 @@ import HscTypes ( HscEnv(..), PersistentCompilerState(..), GlobalRdrEnv, LocalRdrEnv, NameCache, FixityEnv, GhciMode, lookupType, unQualInScope ) import TcRnTypes -import Module ( Module, foldModuleEnv ) +import Module ( Module, unitModuleEnv, foldModuleEnv ) import Name ( Name, isInternalName ) import Type ( Type ) import NameEnv ( extendNameEnvList ) @@ -35,10 +35,12 @@ import Unique ( Unique ) import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug ) import BasicTypes ( FixitySig ) import Bag ( snocBag, unionBags ) - +import Panic ( showException ) + import Maybe ( isJust ) import IO ( stderr ) import DATA_IOREF ( newIORef, readIORef ) +import EXCEPTION ( Exception ) \end{code} %************************************************************************ @@ -114,7 +116,8 @@ initTc (HscEnv { hsc_mode = ghci_mode, usg_var <- newIORef emptyUsages ; nc_var <- newIORef (pcs_nc pcs) ; eps_var <- newIORef eps ; - + ie_var <- newIORef (mkImpInstEnv dflags eps hpt) ; + let { env = Env { env_top = top_env, env_gbl = gbl_env, @@ -137,10 +140,9 @@ initTc (HscEnv { hsc_mode = ghci_mode, tcg_fix_env = emptyFixityEnv, tcg_default = defaultDefaultTys, tcg_type_env = emptyNameEnv, - tcg_ist = mkImpTypeEnv eps hpt, - tcg_inst_env = mkImpInstEnv dflags eps hpt, + tcg_inst_env = ie_var, tcg_exports = [], - tcg_imports = emptyImportAvails, + tcg_imports = init_imports, tcg_binds = EmptyMonoBinds, tcg_deprecs = NoDeprecs, tcg_insts = [], @@ -148,11 +150,12 @@ initTc (HscEnv { hsc_mode = ghci_mode, tcg_fords = [] } ; lcl_env = TcLclEnv { - tcl_ctxt = [], - tcl_level = topStage, - tcl_env = emptyNameEnv, - tcl_tyvars = tvs_var, - tcl_lie = panic "initTc:LIE" } ; + tcl_ctxt = [], + tcl_th_ctxt = topStage, + tcl_arrow_ctxt = topArrowCtxt, + tcl_env = emptyNameEnv, + tcl_tyvars = tvs_var, + tcl_lie = panic "initTc:LIE" } ; -- LIE only valid inside a getLIE } ; @@ -169,18 +172,30 @@ initTc (HscEnv { hsc_mode = ghci_mode, eps' <- readIORef eps_var ; nc' <- readIORef nc_var ; let { pcs' = PCS { pcs_EPS = eps', pcs_nc = nc' } ; - final_res | errorsFound msgs = Nothing - | otherwise = maybe_res } ; + final_res | errorsFound dflags msgs = Nothing + | otherwise = maybe_res } ; return (pcs', final_res) } where eps = pcs_EPS pcs + init_imports = emptyImportAvails { imp_qual = unitModuleEnv mod emptyAvailEnv } + -- Initialise tcg_imports with an empty set of bindings for + -- this module, so that if we see 'module M' in the export + -- list, and there are no bindings in M, we don't bleat + -- "unknown module M". + defaultDefaultTys :: [Type] defaultDefaultTys = [integerTy, doubleTy] mkImpInstEnv :: DynFlags -> ExternalPackageState -> HomePackageTable -> InstEnv +-- At the moment we (wrongly) build an instance environment from all the +-- modules we have already compiled: +-- (a) eps_inst_env from the external package state +-- (b) all the md_insts in the home package table +-- We should really only get instances from modules below us in the +-- module import tree. mkImpInstEnv dflags eps hpt = foldModuleEnv (add . md_insts . hm_details) (eps_inst_env eps) @@ -188,7 +203,7 @@ mkImpInstEnv dflags eps hpt where -- We shouldn't get instance conflict errors from -- the package and home type envs - add dfuns inst_env = WARN( not (null errs), vcat errs ) inst_env' + add dfuns inst_env = WARN( not (null errs), vcat (map snd errs) ) inst_env' where (inst_env', errs) = extendInstEnv dflags inst_env dfuns @@ -232,8 +247,15 @@ updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> setLclEnv :: m -> TcRn m a -> TcRn n a setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) + +getEnvs :: TcRn m (TcGblEnv, m) +getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } + +setEnvs :: (TcGblEnv, m) -> TcRn m a -> TcRn m a +setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) \end{code} + Command-line flags \begin{code} @@ -276,6 +298,9 @@ getModule = do { env <- getGblEnv; return (tcg_mod env) } getGlobalRdrEnv :: TcRn m GlobalRdrEnv getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } +getImports :: TcRn m ImportAvails +getImports = do { env <- getGblEnv; return (tcg_imports env) } + getFixityEnv :: TcRn m FixityEnv getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) } @@ -289,13 +314,13 @@ getDefaultTys = do { env <- getGblEnv; return (tcg_default env) } \end{code} \begin{code} -getUsageVar :: TcRn m (TcRef Usages) +getUsageVar :: TcRn m (TcRef EntityUsage) getUsageVar = do { env <- getGblEnv; return (tcg_usages env) } -getUsages :: TcRn m Usages +getUsages :: TcRn m EntityUsage getUsages = do { usg_var <- getUsageVar; readMutVar usg_var } -updUsages :: (Usages -> Usages) -> TcRn m () +updUsages :: (EntityUsage -> EntityUsage) -> TcRn m () updUsages upd = do { usg_var <- getUsageVar ; usg <- readMutVar usg_var ; writeMutVar usg_var (upd usg) } @@ -317,18 +342,20 @@ setErrsVar v = updEnv (\ env@(Env { env_top = top_env }) -> env { env_top = top_env { top_errs = v }}) addErr :: Message -> TcRn m () -addErr msg = do { loc <- getSrcLocM ; add_err loc msg } +addErr msg = do { loc <- getSrcLocM ; addErrAt loc msg } -add_err :: SrcLoc -> Message -> TcRn m () -add_err loc msg +addErrAt :: SrcLoc -> Message -> TcRn m () +addErrAt loc msg = do { errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; let { err = addShortErrLocLine loc (unQualInScope rdr_env) msg } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } -addErrs :: [Message] -> TcRn m () -addErrs msgs = mappM_ addErr msgs +addErrs :: [(SrcLoc,Message)] -> TcRn m () +addErrs msgs = mappM_ add msgs + where + add (loc,msg) = addErrAt loc msg addWarn :: Message -> TcRn m () addWarn msg @@ -353,57 +380,68 @@ addMessages (m_warns, m_errs) (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns `unionBags` m_warns, errs `unionBags` m_errs) } - -checkGHCI :: Message -> TcRn m () -- Check that GHCI is on - -- otherwise add the error message -#ifdef GHCI -checkGHCI m = returnM () -#else -checkGHCI m = addErr m -#endif \end{code} \begin{code} -tryM :: TcRn m a -> TcRn m (Messages, Maybe a) - -- (try m) executes m, and returns +recoverM :: TcRn m r -- Recovery action; do this if the main one fails + -> TcRn m r -- Main action: do this first + -> TcRn m r +recoverM recover thing + = do { mb_res <- try_m thing ; + case mb_res of + Left exn -> recover + Right res -> returnM res } + +tryTc :: TcRn m a -> TcRn m (Messages, Maybe a) + -- (tryTc m) executes m, and returns -- Just r, if m succeeds (returning r) and caused no errors -- Nothing, if m fails, or caused errors -- It also returns all the errors accumulated by m -- (even in the Just case, there might be warnings) -- -- It always succeeds (never raises an exception) -tryM m +tryTc m = do { errs_var <- newMutVar emptyMessages ; - mb_r <- recoverM (return Nothing) - (do { r <- setErrsVar errs_var m ; - return (Just r) }) ; + mb_r <- try_m (setErrsVar errs_var m) ; new_errs <- readMutVar errs_var ; + dflags <- getDOpts ; + return (new_errs, case mb_r of - Nothing -> Nothing - Just r | errorsFound new_errs -> Nothing - | otherwise -> Just r) + Left exn -> Nothing + Right r | errorsFound dflags new_errs -> Nothing + | otherwise -> Just r) } -tryTc :: TcM a -> TcM (Messages, Maybe a) --- Just like tryM, except that it ensures that the LIE +try_m :: TcRn m r -> TcRn m (Either Exception r) +-- Does try_m, with a debug-trace on failure +try_m thing + = do { mb_r <- tryM thing ; + case mb_r of + Left exn -> do { traceTc (exn_msg exn); return mb_r } + Right r -> return mb_r } + where + exn_msg exn = text "recoverM recovering from" <+> text (showException exn) + +tryTcLIE :: TcM a -> TcM (Messages, Maybe a) +-- Just like tryTc, except that it ensures that the LIE -- for the thing is propagated only if there are no errors -- Hence it's restricted to the type-check monad -tryTc thing_inside - = do { ((errs, mb_r), lie) <- getLIE (tryM thing_inside) ; +tryTcLIE thing_inside + = do { ((errs, mb_r), lie) <- getLIE (tryTc thing_inside) ; ifM (isJust mb_r) (extendLIEs lie) ; return (errs, mb_r) } -tryTc_ :: TcM r -> TcM r -> TcM r --- (tryM_ r m) tries m; if it succeeds it returns it, +tryTcLIE_ :: TcM r -> TcM r -> TcM r +-- (tryTcLIE_ r m) tries m; if it succeeds it returns it, -- otherwise it returns r. Any error messages added by m are discarded, -- whether or not m succeeds. -tryTc_ recover main - = do { (_msgs, mb_res) <- tryTc main ; +tryTcLIE_ recover main + = do { (_msgs, mb_res) <- tryTcLIE main ; case mb_res of Just res -> return res Nothing -> recover } @@ -416,7 +454,7 @@ checkNoErrs :: TcM r -> TcM r -- If so, it fails too. -- Regardless, any errors generated by m are propagated to the enclosing context. checkNoErrs main - = do { (msgs, mb_res) <- tryTc main ; + = do { (msgs, mb_res) <- tryTcLIE main ; addMessages msgs ; case mb_res of Just r -> return r @@ -430,7 +468,8 @@ ifErrsM :: TcRn m r -> TcRn m r -> TcRn m r ifErrsM bale_out normal = do { errs_var <- getErrsVar ; msgs <- readMutVar errs_var ; - if errorsFound msgs then + dflags <- getDOpts ; + if errorsFound dflags msgs then bale_out else normal } @@ -445,6 +484,7 @@ forkM :: SDoc -> TcM a -> TcM (Maybe a) -- Run thing_inside in an interleaved thread. It gets a separate -- * errs_var, and -- * unique supply, +-- * LIE var is set to bottom (should never be used) -- but everything else is shared, so this is DANGEROUS. -- -- It returns Nothing if the computation fails @@ -456,13 +496,19 @@ forkM doc thing_inside = do { us <- newUniqueSupply ; unsafeInterleaveM $ do { us_var <- newMutVar us ; - (msgs, mb_res) <- tryTc (setUsVar us_var thing_inside) ; + (msgs, mb_res) <- tryTc (setLIEVar (panic "forkM: LIE used") $ + setUsVar us_var thing_inside) ; case mb_res of Just r -> return (Just r) Nothing -> do { - -- Bleat about errors in the forked thread - ioToTcRn (do { printErrs (hdr_doc defaultErrStyle) ; - printErrorsAndWarnings msgs }) ; + + -- Bleat about errors in the forked thread, if -ddump-tc-trace is on + -- Otherwise we silently discard errors. Errors can legitimately + -- happen when compiling interface signatures (see tcInterfaceSigs) + ifOptM Opt_D_dump_tc_trace + (ioToTcRn (do { printErrs (hdr_doc defaultErrStyle) ; + printErrorsAndWarnings msgs })) ; + return Nothing } }} where @@ -519,6 +565,7 @@ setNameCache nc = do { TopEnv { top_nc = nc_var } <- getTopEnv; traceTc, traceRn :: SDoc -> TcRn a () traceRn = dumpOptTcRn Opt_D_dump_rn_trace traceTc = dumpOptTcRn Opt_D_dump_tc_trace +traceSplice = dumpOptTcRn Opt_D_dump_splices traceHiDiffs = dumpOptTcRn Opt_D_dump_hi_diffs dumpOptTcRn :: DynFlag -> SDoc -> TcRn a () @@ -560,10 +607,16 @@ updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> getInstLoc :: InstOrigin -> TcM InstLoc getInstLoc origin = do { loc <- getSrcLocM ; env <- getLclEnv ; - return (origin, loc, (tcl_ctxt env)) } + return (InstLoc origin loc (tcl_ctxt env)) } + +addInstCtxt :: InstLoc -> TcM a -> TcM a +-- Add the SrcLoc and context from the first Inst in the list +-- (they all have similar locations) +addInstCtxt (InstLoc _ src_loc ctxt) thing_inside + = addSrcLoc src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside) \end{code} - The addErr functions add an error message, but do not cause failure. + 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 @@ -579,12 +632,6 @@ addErrTcM (tidy_env, err_msg) = do { ctxt <- getErrCtxt ; loc <- getSrcLocM ; add_err_tcm tidy_env err_msg loc ctxt } - -addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> TcM () -addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) - = add_err_tcm tidy_env err_msg loc full_ctxt - where - full_ctxt = (\env -> returnM (env, pprInstLoc inst_loc)) : ctxt \end{code} The failWith functions add an error message and cause failure @@ -623,7 +670,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 ; - add_err loc (vcat (err_msg : ctxt_to_use ctxt_msgs)) } + addErrAt loc (vcat (err_msg : ctxt_to_use ctxt_msgs)) } do_ctxt tidy_env [] = return [] @@ -638,7 +685,7 @@ ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt %************************************************************************ %* * - Other stuff specific to type checker + Type constraints (the so-called LIE) %* * %************************************************************************ @@ -673,14 +720,7 @@ extendLIEs insts writeMutVar lie_var (mkLIE insts `plusLIE` lie) } \end{code} - \begin{code} -getStage :: TcM Stage -getStage = do { env <- getLclEnv; return (tcl_level env) } - -setStage :: Stage -> TcM a -> TcM a -setStage s = updLclEnv (\ env -> env { tcl_level = s }) - setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a -- Set the local type envt, but do *not* disturb other fields, -- notably the lie_var @@ -694,6 +734,47 @@ setLclTypeEnv lcl_env thing_inside %************************************************************************ %* * + Template Haskell context +%* * +%************************************************************************ + +\begin{code} +getStage :: TcM ThStage +getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) } + +setStage :: ThStage -> TcM a -> TcM a +setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) +\end{code} + + +%************************************************************************ +%* * + Arrow context +%* * +%************************************************************************ + +\begin{code} +popArrowBinders :: TcM a -> TcM a -- Move to the left of a (-<); see comments in TcRnTypes +popArrowBinders + = updLclEnv (\ env -> env { tcl_arrow_ctxt = pop (tcl_arrow_ctxt env) }) + where + pop (ArrCtxt {proc_level = curr_lvl, proc_banned = banned}) + = ASSERT( not (curr_lvl `elem` banned) ) + ArrCtxt {proc_level = curr_lvl, proc_banned = curr_lvl : banned} + +getBannedProcLevels :: TcM [ProcLevel] + = do { env <- getLclEnv; return (proc_banned (tcl_arrow_ctxt env)) } + +incProcLevel :: TcM a -> TcM a +incProcLevel + = updLclEnv (\ env -> env { tcl_arrow_ctxt = inc (tcl_arrow_ctxt env) }) + where + inc ctxt = ctxt { proc_level = proc_level ctxt + 1 } +\end{code} + + +%************************************************************************ +%* * Stuff for the renamer's local env %* * %************************************************************************ @@ -701,8 +782,7 @@ setLclTypeEnv lcl_env thing_inside \begin{code} initRn :: RnMode -> RnM a -> TcRn m a initRn mode thing_inside - = do { env <- getGblEnv ; - let { lcl_env = RnLclEnv { + = do { let { lcl_env = RnLclEnv { rn_mode = mode, rn_lenv = emptyRdrEnv }} ; setLclEnv lcl_env thing_inside }