X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=f0942b152bdaafe08ceef1ae9a7bfda09089eb4b;hp=4e0f283cdd2cb757d5fd4744c49b39407e05a55d;hb=d51f42f602bf9a6d1b356c41228a534c88723f65;hpb=9ac57e65bb77638ff7d5e7148ee5c3d80b25cf7d diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 4e0f283..f0942b1 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -5,6 +5,13 @@ \section[TcModule]{Typechecking a whole module} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcRnDriver ( #ifdef GHCI tcRnStmt, tcRnExpr, tcRnType, @@ -12,7 +19,6 @@ module TcRnDriver ( tcRnLookupName, tcRnGetInfo, getModuleExports, - tcRnRecoverDataCon, #endif tcRnModule, tcTopSrcDecls, @@ -63,7 +69,7 @@ import ErrUtils import Id import Var import Module -import UniqFM +import LazyUniqFM import Name import NameEnv import NameSet @@ -72,7 +78,6 @@ import SrcLoc import HscTypes import ListSetOps import Outputable -import Breakpoints #ifdef GHCI import Linker @@ -89,6 +94,7 @@ import TysWiredIn import IdInfo import {- Kind parts of -} Type import BasicTypes +import Foreign.Ptr( Ptr ) #endif import FastString @@ -96,7 +102,9 @@ import Maybes import Util import Bag -import Control.Monad ( unless ) +import Control.Monad +import Data.Maybe ( isJust ) + \end{code} @@ -117,7 +125,7 @@ tcRnModule :: HscEnv tcRnModule hsc_env hsc_src save_rn_syntax (L loc (HsModule maybe_mod export_ies - import_decls local_decls mod_deprec _ + import_decls local_decls mod_deprec module_info maybe_doc)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; @@ -162,8 +170,9 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcg_env <- finishDeprecations (hsc_dflags hsc_env) mod_deprec tcg_env ; -- Process the export list + traceRn (text "rn4a: before exports"); tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; - traceRn (text "rn4") ; + traceRn (text "rn4b: after exportss") ; -- Compare the hi-boot iface (if any) with the real thing -- Must be done after processing the exports @@ -196,7 +205,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax \begin{code} tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv tcRnImports hsc_env this_mod import_decls - = do { (rn_imports, rdr_env, imports) <- rnImports import_decls ; + = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) ; dep_mods = imp_dep_mods imports @@ -208,7 +217,8 @@ tcRnImports hsc_env this_mod import_decls ; want_instances :: ModuleName -> Bool ; want_instances mod = mod `elemUFM` dep_mods && mod /= moduleName this_mod - ; home_insts = hptInstances hsc_env want_instances + ; (home_insts, home_fam_insts) = hptInstances hsc_env + want_instances } ; -- Record boot-file info in the EPS, so that it's @@ -218,11 +228,15 @@ tcRnImports hsc_env this_mod import_decls -- Update the gbl env ; updGblEnv ( \ gbl -> - gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_imports = fmap (const rn_imports) (tcg_rn_imports gbl), - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts - }) $ do { + gbl { + tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_rn_imports = fmap (const rn_imports) (tcg_rn_imports gbl), + tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + home_fam_insts, + tcg_hpc = hpc_info + }) $ do { ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) -- Fail if there are any errors so far @@ -239,7 +253,7 @@ tcRnImports hsc_env this_mod import_decls -- Check type-familily consistency ; traceRn (text "rn1: checking family instance consistency") - ; let { dir_imp_mods = map (\ (mod, _, _) -> mod) + ; let { dir_imp_mods = map (\ (mod, _) -> mod) . moduleEnvElts . imp_mods $ imports } @@ -269,21 +283,26 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) let { ldecls = map noLoc decls } ; - -- Deal with the type declarations; first bring their stuff - -- into scope, then rname them, then type check them - tcg_env <- importsFromLocalDecls (mkFakeGroup ldecls) ; + -- bring the type and class decls into scope + -- ToDo: check that this doesn't need to extract the val binds. + -- It seems that only the type and class decls need to be in scope below because + -- (a) tcTyAndClassDecls doesn't need the val binds, and + -- (b) tcExtCoreBindings doesn't need anything + -- (in fact, it might not even need to be in the scope of + -- this tcg_env at all) + tcg_env <- importsFromLocalDecls False (mkFakeGroup ldecls) + emptyUFM {- no fixity decls -} ; setGblEnv tcg_env $ do { - rn_decls <- rnTyClDecls ldecls ; - failIfErrsM ; + rn_decls <- checkNoErrs $ rnTyClDecls ldecls ; -- Dump trace of renaming part rnDump (ppr rn_decls) ; -- Typecheck them all together so that -- any mutually recursive types are done right - tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ; + tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ; -- Make the new type env available to stuff slurped from interface files setGblEnv tcg_env $ do { @@ -301,13 +320,14 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mod_guts = ModGuts { mg_module = this_mod, mg_boot = False, - mg_usages = [], -- ToDo: compute usage - mg_dir_imps = [], -- ?? + mg_used_names = emptyNameSet, -- ToDo: compute usage + mg_dir_imps = emptyModuleEnv, -- ?? mg_deps = noDependencies, -- ?? mg_exports = my_exports, mg_types = final_type_env, mg_insts = tcg_insts tcg_env, mg_fam_insts = tcg_fam_insts tcg_env, + mg_inst_env = tcg_inst_env tcg_env, mg_fam_inst_env = tcg_fam_inst_env tcg_env, mg_rules = [], mg_binds = core_binds, @@ -317,8 +337,9 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_fix_env = emptyFixityEnv, mg_deprecs = NoDeprecs, mg_foreign = NoStubs, - mg_hpc_info = noHpcInfo, - mg_dbg_sites = noDbgSites + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo } } ; tcCoreDump mod_guts ; @@ -370,6 +391,10 @@ tcRnSrcDecls boot_iface decls tcg_rules = rules, tcg_fords = fords } = tcg_env ; all_binds = binds `unionBags` inst_binds } ; + failIfErrsM ; -- Don't zonk if there have been errors + -- It's a waste of time; and we may get debug warnings + -- about strangely-typed TyCons! + (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids @@ -389,8 +414,8 @@ tc_rn_src_decls boot_details ds -- If ds is [] we get ([], Nothing) -- Deal with decls up to, but not including, the first splice - (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ; - -- checkNoErrs: stop if renaming fails + (tcg_env, rn_decls) <- rnTopSrcDecls first_group ; + -- rnTopSrcDecls fails if there are any errors (tcg_env, tcl_env) <- setGblEnv tcg_env $ tcTopSrcDecls boot_details rn_decls ; @@ -448,7 +473,7 @@ tcRnHsBootDecls decls -- Typecheck type/class decls ; traceTc (text "Tc2") ; let tycl_decls = hs_tyclds rn_group - ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls) + ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls ; setGblEnv tcg_env $ do { -- Typecheck instance decls @@ -616,18 +641,12 @@ monad; it augments it and returns the new TcGblEnv. \begin{code} ------------------------------------------------ rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) +-- Fails if there are any errors rnTopSrcDecls group - = do { -- Bring top level binders into scope - tcg_env <- importsFromLocalDecls group ; - setGblEnv tcg_env $ do { - - failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations + = do { -- Rename the source decls (with no shadowing; error on duplicates) + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls False group ; - -- Rename the source decls - (tcg_env, rn_decls) <- rnSrcDecls group ; - failIfErrsM ; - - -- save the renamed syntax, if we want it + -- save the renamed syntax, if we want it let { tcg_env' | Just grp <- tcg_rn_decls tcg_env = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } @@ -638,7 +657,7 @@ rnTopSrcDecls group rnDump (ppr rn_decls) ; return (tcg_env', rn_decls) - }} + } ------------------------------------------------ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) @@ -654,9 +673,8 @@ tcTopSrcDecls boot_details -- The latter come in via tycl_decls traceTc (text "Tc2") ; - tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ; - -- tcTyAndClassDecls recovers internally, but if anything gave rise to - -- an error we'd better stop now, to avoid a cascade + tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; + -- If there are any errors, tcTyAndClassDecls fails here -- Make these type and class decls available to stuff slurped from interface files writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; @@ -685,12 +703,17 @@ tcTopSrcDecls boot_details -- We also typecheck any extra binds that came out -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; - (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ; + (tc_val_binds, tcl_env) <- tcTopBinds val_binds ; setLclTypeEnv tcl_env $ do { + -- Now GHC-generated derived bindings and generics. + -- Do not generate warnings from compiler-generated code. + (tc_deriv_binds, tcl_env) <- discardWarnings $ + tcTopBinds deriv_binds ; + -- Second pass over class and instance declarations, traceTc (text "Tc6") ; - (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ; + (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ tcInstDecls2 tycl_decls inst_infos ; showLIE (text "after instDecls2") ; -- Foreign exports @@ -705,6 +728,7 @@ tcTopSrcDecls boot_details traceTc (text "Tc7a") ; tcg_env <- getGblEnv ; let { all_binds = tc_val_binds `unionBags` + tc_deriv_binds `unionBags` inst_binds `unionBags` foe_binds ; @@ -728,26 +752,18 @@ tcTopSrcDecls boot_details checkMain :: TcM TcGblEnv -- If we are in module Main, check that 'main' is defined. checkMain - = do { ghc_mode <- getGhcMode ; - tcg_env <- getGblEnv ; + = do { tcg_env <- getGblEnv ; dflags <- getDOpts ; - let { main_mod = mainModIs dflags ; - main_fn = case mainFunIs dflags of { - Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ; - Nothing -> main_RDR_Unqual } } ; - - check_main ghc_mode tcg_env main_mod main_fn + check_main dflags tcg_env } - -check_main ghc_mode tcg_env main_mod main_fn +check_main dflags tcg_env | mod /= main_mod = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >> return tcg_env | otherwise - = addErrCtxt mainCtxt $ - do { mb_main <- lookupSrcOcc_maybe main_fn + = do { mb_main <- lookupSrcOcc_maybe main_fn -- Check that 'main' is in scope -- It might be imported from another module! ; case mb_main of { @@ -755,17 +771,19 @@ check_main ghc_mode tcg_env main_mod main_fn ; complain_no_main ; return tcg_env } ; Just main_name -> do + { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn) ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) } -- :Main.main :: IO () = runMainIO main - ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $ + ; (main_expr, ty) <- addErrCtxt mainCtxt $ + setSrcSpan (srcLocSpan (getSrcLoc main_name)) $ tcInferRho rhs -- See Note [Root-main Id] ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN (mkVarOccFS FSLIT("main")) - (getSrcLoc main_name) + (getSrcSpan main_name) ; root_main_id = Id.mkExportedLocalId root_main_name ty ; main_bind = noLoc (VarBind root_main_id main_expr) } @@ -778,17 +796,25 @@ check_main ghc_mode tcg_env main_mod main_fn }) }}} where - mod = tcg_mod tcg_env - - complain_no_main | ghc_mode == Interactive = return () - | otherwise = failWithTc noMainMsg + mod = tcg_mod tcg_env + main_mod = mainModIs dflags + main_is_flag = mainFunIs dflags + + main_fn = case main_is_flag of + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) + Nothing -> main_RDR_Unqual + + complain_no_main | ghcLink dflags == LinkInMemory = return () + | otherwise = failWithTc noMainMsg -- In interactive mode, don't worry about the absence of 'main' -- In other modes, fail altogether, so that we don't go on -- and complain a second time when processing the export list. - mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn) - noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn) + mainCtxt = ptext SLIT("When checking the type of the") <+> pp_main_fn + noMainMsg = ptext SLIT("The") <+> pp_main_fn <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) + pp_main_fn | isJust main_is_flag = ptext SLIT("main function") <+> quotes (ppr main_fn) + | otherwise = ptext SLIT("function") <+> quotes (ppr main_fn) \end{code} Note [Root-main Id] @@ -814,20 +840,29 @@ get two defns for 'main' in the interface file! #ifdef GHCI setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a setInteractiveContext hsc_env icxt thing_inside - = let - -- Initialise the tcg_inst_env with instances - -- from all home modules. This mimics the more selective - -- call to hptInstances in tcRnModule - dfuns = hptInstances hsc_env (\mod -> True) + = let -- Initialise the tcg_inst_env with instances from all home modules. + -- This mimics the more selective call to hptInstances in tcRnModule. + (home_insts, home_fam_insts) = hptInstances hsc_env (\mod -> True) in updGblEnv (\env -> env { - tcg_rdr_env = ic_rn_gbl_env icxt, - tcg_type_env = ic_type_env icxt, - tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $ - - updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $ - - do { traceTc (text "setIC" <+> ppr (ic_type_env icxt)) + tcg_rdr_env = ic_rn_gbl_env icxt, + tcg_inst_env = extendInstEnvList (tcg_inst_env env) home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env) + home_fam_insts + }) $ + + tcExtendGhciEnv (ic_tmp_ids icxt) $ + -- tcExtendGhciEnv does lots: + -- - it extends the local type env (tcl_env) with the given Ids, + -- - it extends the local rdr env (tcl_rdr) with the Names from + -- the given Ids + -- - it adds the free tyvars of the Ids to the tcl_tyvars + -- set. + -- + -- later ids in ic_tmp_ids must shadow earlier ones with the same + -- OccName, and tcExtendIdEnv implements this behaviour. + + do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt)) ; thing_inside } \end{code} @@ -836,9 +871,10 @@ setInteractiveContext hsc_env icxt thing_inside tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName - -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id)) - -- The returned [Name] is the same as the input except for - -- ExprStmt, in which case the returned [Name] is [itName] + -> IO (Maybe ([Id], LHsExpr Id)) + -- The returned [Id] is the list of new Ids bound by + -- this statement. It can be used to extend the + -- InteractiveContext via extendInteractiveContext. -- -- The returned TypecheckedHsExpr is of type IO [ () ], -- a list of the bound values, coerced to (). @@ -851,6 +887,7 @@ tcRnStmt hsc_env ictxt rdr_stmt (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; failIfErrsM ; + rnDump (ppr rn_stmt) ; -- The real work is done here (bound_ids, tc_expr) <- mkPlan rn_stmt ; @@ -859,27 +896,11 @@ tcRnStmt hsc_env ictxt rdr_stmt -- None of the Ids should be of unboxed type, because we -- cast them all to HValues in the end! - mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; + mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; traceTc (text "tcs 1") ; - let { -- (a) Make all the bound ids "global" ids, now that - -- they're notionally top-level bindings. This is - -- important: otherwise when we come to compile an expression - -- using these ids later, the byte code generator will consider - -- the occurrences to be free rather than global. - -- - -- (b) Tidy their types; this is important, because :info may - -- ask to look at them, and :info expects the things it looks - -- up to have tidy types - global_ids = map globaliseAndTidy zonked_ids ; + let { global_ids = map globaliseAndTidy zonked_ids } ; - -- Update the interactive context - rn_env = ic_rn_local_env ictxt ; - type_env = ic_type_env ictxt ; - - bound_names = map idName global_ids ; - new_rn_env = extendLocalRdrEnv rn_env bound_names ; - {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env; they are inaccessible but might, I suppose, cause a space leak if we leave them there. @@ -897,35 +918,48 @@ tcRnStmt hsc_env ictxt rdr_stmt Hence this code is commented out - shadowed = [ n | name <- bound_names, - let rdr_name = mkRdrUnqual (nameOccName name), - Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ; - filtered_type_env = delListFromNameEnv type_env shadowed ; -------------------------------------------------- -} - new_type_env = extendTypeEnvWithIds type_env global_ids ; - new_ic = ictxt { ic_rn_local_env = new_rn_env, - ic_type_env = new_type_env } - } ; - dumpOptTcRn Opt_D_dump_tc (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, text "Typechecked expr" <+> ppr zonked_expr]) ; - returnM (new_ic, bound_names, zonked_expr) + return (global_ids, zonked_expr) } where bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) globaliseAndTidy :: Id -> Id -globaliseAndTidy id --- Give the Id a Global Name, and tidy its type +globaliseAndTidy id -- Note [Interactively-bound Ids in GHCi] = Id.setIdType (globaliseId VanillaGlobal id) tidy_type where tidy_type = tidyTopType (idType id) \end{code} +Note [Interactively-bound Ids in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Ids bound by previous Stmts in Template Haskell are currently + a) GlobalIds + b) with an Internal Name (not External) + c) and a tidied type + + (a) They must be GlobalIds (not LocalIds) otherwise when we come to + compile an expression using these ids later, the byte code + generator will consider the occurrences to be free rather than + global. + + (b) They retain their Internal names becuase we don't have a suitable + Module to name them with. We could revisit this choice. + + (c) Their types are tidied. This is important, because :info may ask + to look at them, and :info expects the things it looks up to have + tidy types + + +-------------------------------------------------------------------------- + Typechecking Stmts in GHCi + Here is the grand plan, implemented in tcUserStmt What you type The IO [HValue] that hscStmt returns @@ -978,7 +1012,7 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt ; runPlans [ -- Plan A do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] ; it_ty <- zonkTcType (idType it_id) - ; ifM (isUnitTy it_ty) failM + ; when (isUnitTy it_ty) failM ; return stuff }, -- Plan B; a naked bind statment @@ -1003,7 +1037,7 @@ mkPlan stmt@(L loc (BindStmt {})) ; let print_plan = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] ; v_ty <- zonkTcType (idType v_id) - ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } -- The plans are: @@ -1022,10 +1056,9 @@ tcGhciStmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; ret_id <- tcLookupId returnIOName ; -- return @ IO let { - io_ty = mkTyConApp ioTyCon [] ; ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts + tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts (emptyRefinement, io_ret_ty) ; names = map unLoc (collectLStmtsBinders stmts) ; @@ -1048,16 +1081,18 @@ tcGhciStmts stmts } ; -- OK, we're ready to typecheck the stmts - traceTc (text "tcs 2") ; + traceTc (text "TcRnDriver.tcGhciStmts: tc stmts") ; ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ -> - mappM tcLookupId names ; + mapM tcLookupId names ; -- Look up the names right in the middle, -- where they will all be in scope -- Simplify the context + traceTc (text "TcRnDriver.tcGhciStmts: simplify ctxt") ; const_binds <- checkNoErrs (tcSimplifyInteractive lie) ; -- checkNoErrs ensures that the plan fails if context redn fails + traceTc (text "TcRnDriver.tcGhciStmts: done") ; return (ids, mkHsDictLet const_binds $ noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty)) } @@ -1194,19 +1229,23 @@ lookup_rdr_name rdr_name = do { return good_names } -tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon) -tcRnRecoverDataCon hsc_env a - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env (hsc_IC hsc_env) $ - do name <- recoverDataCon a - tcLookupDataCon name - tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) tcRnLookupName hsc_env name = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ - tcLookupGlobal name + tcRnLookupName' name + +-- To look up a name we have to look in the local environment (tcl_lcl) +-- as well as the global environment, which is what tcLookup does. +-- But we also want a TyThing, so we have to convert: +tcRnLookupName' :: Name -> TcRn TyThing +tcRnLookupName' name = do + tcthing <- tcLookup name + case tcthing of + AGlobal thing -> return thing + ATcId{tct_id=id} -> return (AnId id) + _ -> panic "tcRnLookupName'" tcRnGetInfo :: HscEnv -> Name @@ -1230,21 +1269,17 @@ tcRnGetInfo hsc_env name -- in the home package all relevant modules are loaded.) loadUnqualIfaces ictxt - thing <- tcLookupGlobal name + thing <- tcRnLookupName' name fixity <- lookupFixityRn name - ispecs <- lookupInsts (icPrintUnqual ictxt) thing + ispecs <- lookupInsts thing return (thing, fixity, ispecs) -lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance] --- Filter the instances by the ones whose tycons (or clases resp) --- are in scope unqualified. Otherwise we list a whole lot too many! -lookupInsts print_unqual (AClass cls) +lookupInsts :: TyThing -> TcM [Instance] +lookupInsts (AClass cls) = do { inst_envs <- tcGetInstEnvs - ; return [ ispec - | ispec <- classInstances inst_envs cls - , plausibleDFun print_unqual (instanceDFunId ispec) ] } + ; return (classInstances inst_envs cls) } -lookupInsts print_unqual (ATyCon tc) +lookupInsts (ATyCon tc) = do { eps <- getEps -- Load all instances for all classes that are -- in the type environment (which are all the ones -- we've seen in any interface file so far) @@ -1252,22 +1287,12 @@ lookupInsts print_unqual (ATyCon tc) ; return [ ispec | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie , let dfun = instanceDFunId ispec - , relevant dfun - , plausibleDFun print_unqual dfun ] } + , relevant dfun ] } where relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) tc_name = tyConName tc -lookupInsts print_unqual other = return [] - -plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified - = all ok (nameSetToList (tyClsNamesOfType (idType dfun))) - where - ok name | isBuiltInSyntax name = True - | isExternalName name = - isNothing $ fst print_unqual (nameModule name) - (nameOccName name) - | otherwise = True +lookupInsts other = return [] loadUnqualIfaces :: InteractiveContext -> TcM () -- Load the home module for everything that is in scope unqualified @@ -1303,8 +1328,8 @@ tcDump env = do { dflags <- getDOpts ; -- Dump short output if -ddump-types or -ddump-tc - ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn short_dump) ; + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn short_dump) ; -- Dump bindings if -ddump-tc dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) @@ -1317,8 +1342,8 @@ tcDump env tcCoreDump mod_guts = do { dflags <- getDOpts ; - ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn (pprModGuts mod_guts)) ; + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn (pprModGuts mod_guts)) ; -- Dump bindings if -ddump-tc dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }