X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=43b9d388b726eff985756246d474d49d333fffcd;hp=3c9f14bc721bc925ce0c7b96864c5c803bda9bcf;hb=288213d7c2c65fa68ca466c1a1a3378e24fa1151;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 3c9f14b..43b9d38 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -5,11 +5,11 @@ \section[TcModule]{Typechecking a whole module} \begin{code} -{-# OPTIONS_GHC -w #-} +{-# 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/WorkingConventions#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details module TcRnDriver ( @@ -69,7 +69,7 @@ import ErrUtils import Id import Var import Module -import UniqFM +import LazyUniqFM import Name import NameEnv import NameSet @@ -85,7 +85,6 @@ import DataCon import TcHsType import TcMType import TcMatches -import TcGadt import RnTypes import RnExpr import IfaceEnv @@ -102,7 +101,7 @@ import Maybes import Util import Bag -import Control.Monad ( unless ) +import Control.Monad import Data.Maybe ( isJust ) \end{code} @@ -125,7 +124,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" ; @@ -170,8 +169,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 @@ -282,21 +282,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 { @@ -314,8 +319,8 @@ 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, @@ -385,6 +390,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 @@ -404,8 +413,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 ; @@ -463,7 +472,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 @@ -631,18 +640,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 - - -- Rename the source decls - (tcg_env, rn_decls) <- rnSrcDecls group ; - failIfErrsM ; + = do { -- Rename the source decls (with no shadowing; error on duplicates) + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls False group ; - -- 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) } @@ -653,7 +656,7 @@ rnTopSrcDecls group rnDump (ppr rn_decls) ; return (tcg_env', rn_decls) - }} + } ------------------------------------------------ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) @@ -669,9 +672,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) ; @@ -837,16 +839,16 @@ 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 = fst (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_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $ - + 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: @@ -893,19 +895,10 @@ 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 } ; {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env; @@ -925,26 +918,47 @@ tcRnStmt hsc_env ictxt rdr_stmt Hence this code is commented out -------------------------------------------------- -} - } ; dumpOptTcRn Opt_D_dump_tc (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, text "Typechecked expr" <+> ppr zonked_expr]) ; - returnM (global_ids, 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 @@ -997,7 +1011,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 @@ -1022,7 +1036,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: @@ -1041,11 +1055,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 - (emptyRefinement, io_ret_ty) ; + tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts io_ret_ty ; names = map unLoc (collectLStmtsBinders stmts) ; @@ -1069,7 +1081,7 @@ tcGhciStmts stmts -- OK, we're ready to typecheck the stmts 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 @@ -1314,8 +1326,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) @@ -1328,8 +1340,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) }