X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=0218e7e778c4b7f3d71836a072249963a8cfe950;hp=d526fc54f4fbb2acb205220fb7b8089a7cebf660;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hpb=289ee3d0daa95445ead578f2b674987a4187993d diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index d526fc5..0218e7e 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/CodingStyle#Warnings +-- for details + module TcRnDriver ( #ifdef GHCI tcRnStmt, tcRnExpr, tcRnType, @@ -12,7 +19,6 @@ module TcRnDriver ( tcRnLookupName, tcRnGetInfo, getModuleExports, - tcRnRecoverDataCon, #endif tcRnModule, tcTopSrcDecls, @@ -198,7 +204,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 @@ -227,7 +233,8 @@ tcRnImports hsc_env this_mod import_decls 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 + home_fam_insts, + tcg_hpc = hpc_info }) $ do { ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) @@ -245,7 +252,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 } @@ -314,6 +321,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) 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, @@ -323,7 +331,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_fix_env = emptyFixityEnv, mg_deprecs = NoDeprecs, mg_foreign = NoStubs, - mg_hpc_info = noHpcInfo, + mg_hpc_info = emptyHpcInfo False, mg_modBreaks = emptyModBreaks, mg_vect_info = noVectInfo } } ; @@ -695,10 +703,10 @@ tcTopSrcDecls boot_details (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 $ setOptM Opt_GlasgowExts $ - tcTopBinds deriv_binds ; + -- 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") ; @@ -840,8 +848,8 @@ setInteractiveContext hsc_env icxt thing_inside tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $ - tcExtendIdEnv (ic_tmp_ids icxt) $ - -- tcExtendIdEnv does lots: + 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 @@ -876,6 +884,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 ; @@ -1058,16 +1067,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 ; -- 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)) } @@ -1204,13 +1215,6 @@ lookup_rdr_name rdr_name = do { return good_names } -tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon) -tcRnRecoverDataCon hsc_env ptr - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env (hsc_IC hsc_env) $ do - name <- dataConInfoPtrToName ptr - tcLookupDataCon name - tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) tcRnLookupName hsc_env name = initTcPrintErrors hsc_env iNTERACTIVE $ @@ -1251,21 +1255,17 @@ tcRnGetInfo hsc_env name -- in the home package all relevant modules are loaded.) loadUnqualIfaces ictxt - thing <- tcRnLookupName' 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) @@ -1273,22 +1273,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