X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=835752e0e0b21a29f700dc1daa1c5194291b8d3a;hb=e393bb3a7dd22fc27e753af3f18356790e65f73c;hp=8233c06bfb9513680f49897ffcf447dc42099b2e;hpb=c4d85183321cb88070d5e6a76dbc4594ebaf2f48;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 8233c06..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, moduleName, unitModuleEnv, 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,8 +140,7 @@ 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 = init_imports, tcg_binds = EmptyMonoBinds, @@ -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,8 +172,8 @@ 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) } @@ -187,6 +190,12 @@ 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) @@ -238,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} @@ -364,14 +380,6 @@ 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} @@ -380,7 +388,7 @@ 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 <- tryM thing ; + = do { mb_res <- try_m thing ; case mb_res of Left exn -> recover Right res -> returnM res } @@ -396,17 +404,29 @@ tryTc :: TcRn m a -> TcRn m (Messages, Maybe a) tryTc m = do { errs_var <- newMutVar emptyMessages ; - mb_r <- tryM (setErrsVar errs_var m) ; + mb_r <- try_m (setErrsVar errs_var m) ; new_errs <- readMutVar errs_var ; + dflags <- getDOpts ; + return (new_errs, case mb_r of - Left exn -> Nothing - Right r | errorsFound new_errs -> Nothing - | otherwise -> Just r) + Left exn -> Nothing + Right r | errorsFound dflags new_errs -> Nothing + | otherwise -> Just r) } +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 @@ -417,7 +437,7 @@ tryTcLIE thing_inside return (errs, mb_r) } tryTcLIE_ :: TcM r -> TcM r -> TcM r --- (tryM_ r m) tries m; if it succeeds it returns it, +-- (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. tryTcLIE_ recover main @@ -448,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 } @@ -463,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 @@ -474,13 +496,19 @@ forkM doc thing_inside = do { us <- newUniqueSupply ; unsafeInterleaveM $ do { us_var <- newMutVar us ; - (msgs, mb_res) <- tryTcLIE (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 @@ -579,7 +607,13 @@ 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 addErrTc functions add an error message, but do not cause failure. @@ -598,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 @@ -657,7 +685,7 @@ ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt %************************************************************************ %* * - Other stuff specific to type checker + Type constraints (the so-called LIE) %* * %************************************************************************ @@ -692,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 @@ -713,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 %* * %************************************************************************ @@ -720,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 }