X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=58d40382f1c9604cb05a5a6a541e8cbb3b8a07ff;hb=406a82d9e3d48348614fc20030b43297960e96a2;hp=ae5a12ed845515615a9ab54d49b42a73f8d26489;hpb=8133c305d14d748d7720272b1eaa67847d00e241;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index ae5a12e..58d4038 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -16,13 +16,14 @@ module TcRnDriver ( #include "HsVersions.h" #ifdef GHCI -import {-# SOURCE #-} TcSplice( tcSpliceDecls ) +import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) +import DsMeta ( templateHaskellNames ) #endif import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) -import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..), +import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..), - HsGroup(..), + HsGroup(..), SpliceDecl(..), mkSimpleMatch, placeHolderType, toHsType, andMonoBinds, isSrcRule, collectStmtsBinders ) @@ -34,10 +35,10 @@ import PrelNames ( iNTERACTIVE, ioTyConName, printName, dollarMainName, itName, mAIN_Name ) import MkId ( unsafeCoerceId ) -import RdrName ( RdrName, getRdrName, mkUnqual, mkRdrUnqual, +import RdrName ( RdrName, getRdrName, mkRdrUnqual, lookupRdrEnv, elemRdrEnv ) -import RnHsSyn ( RenamedHsDecl, RenamedStmt, RenamedTyClDecl, +import RnHsSyn ( RenamedStmt, RenamedTyClDecl, ruleDeclFVs, instDeclFVs, tyClDeclFVs ) import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl, zonkTopBinds, zonkTopDecls, mkHsLet, @@ -56,8 +57,7 @@ import Inst ( showLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) -import TcEnv ( RecTcGblEnv, - tcExtendGlobalValEnv, +import TcEnv ( tcExtendGlobalValEnv, tcExtendGlobalEnv, tcExtendInstEnv, tcExtendRules, tcLookupTyCon, tcLookupGlobal, @@ -70,16 +70,15 @@ import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 ) import TcSimplify ( tcSimplifyTop, tcSimplifyInfer ) import TcTyClsDecls ( tcTyAndClassDecls ) -import RnNames ( rnImports, exportsFromAvail, reportUnusedNames ) +import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, + reportUnusedNames, main_RDR_Unqual ) import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate ) import RnHiFiles ( readIface, loadOldIface ) import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv, ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs ) import RnExpr ( rnStmts, rnExpr ) -import RnNames ( importsFromLocalDecls ) import RnSource ( rnSrcDecls, checkModDeprec, rnStats ) -import OccName ( varName ) import CoreUnfold ( unfoldingTemplate ) import CoreSyn ( IdCoreRule, Bind(..) ) import PprCore ( pprIdRules, pprCoreBindings ) @@ -88,7 +87,7 @@ import ErrUtils ( mkDumpDoc, showPass ) import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported ) import IdInfo ( GlobalIdDetails(..) ) import Var ( Var, setGlobalIdDetails ) -import Module ( Module, moduleName, moduleUserString ) +import Module ( Module, moduleName, moduleUserString, moduleEnvElts ) import Name ( Name, isExternalName, getSrcLoc, nameOccName ) import NameEnv ( delListFromNameEnv ) import NameSet @@ -100,7 +99,7 @@ import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), ModIface, ModDetails(..), ModGuts(..), HscEnv(..), ModIface(..), ModDetails(..), IfaceDecls(..), - GhciMode(..), + GhciMode(..), noDependencies, Deprecations(..), plusDeprecs, emptyGlobalRdrEnv, GenAvailInfo(Avail), availsToNameSet, @@ -145,9 +144,9 @@ tcRnModule hsc_env pcs do { -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env, - tcg_imports = imports }) + tcg_imports = tcg_imports gbl `plusImportAvails` imports }) $ do { - traceRn (text "rn1") ; + traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ; -- Fail if there are any errors so far -- The error printing (if needed) takes advantage -- of the tcg_env we have now set @@ -172,14 +171,17 @@ tcRnModule hsc_env pcs updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs }) $ do { - traceRn (text "rn4") ; -- Process the export list export_avails <- exportsFromAvail exports ; updGblEnv (\gbl -> gbl { tcg_exports = export_avails }) $ do { - -- Get the supporting decls for the exports - -- This is important *only* to gether usage information + -- Get any supporting decls for the exports that have not already + -- been sucked in for the declarations in the body of the module. + -- (This can happen if something is imported only to be re-exported.) + -- + -- Importing these supporting declarations is required + -- *only* to gether usage information -- (see comments with MkIface.mkImportInfo for why) -- For OneShot compilation we could just throw away the decls -- but for Batch or Interactive we must put them in the type @@ -261,8 +263,11 @@ tcRnStmt :: HscEnv -> PersistentCompilerState -> RdrNameStmt -> IO (PersistentCompilerState, Maybe (InteractiveContext, [Name], TypecheckedHsExpr)) - -- The returned [Id] is the same as the input except for + -- The returned [Name] is the same as the input except for -- ExprStmt, in which case the returned [Name] is [itName] + -- + -- The returned TypecheckedHsExpr is of type IO [ () ], + -- a list of the bound values, coerced to (). tcRnStmt hsc_env pcs ictxt rdr_stmt = initTc hsc_env pcs iNTERACTIVE $ @@ -486,9 +491,16 @@ tcRnThing hsc_env pcs ictxt rdr_name do { addMessages (head msgs_s) ; failM } else do { - mapM_ addMessages msgs_s ; -- Add deprecation warnings - mapM tcLookupGlobal names -- and lookup up the entities - }} + -- Add deprecation warnings + mapM_ addMessages msgs_s ; + + -- Slurp in the supporting declarations + tcg_env <- importSupportingDecls (mkFVs names) ; + setGblEnv tcg_env $ do { + + -- And lookup up the entities + mapM tcLookupGlobal names + }}} \end{code} @@ -557,6 +569,7 @@ tcRnExtCore hsc_env pcs mod_guts = ModGuts { mg_module = this_mod, mg_usages = [], -- ToDo: compute usage mg_dir_imps = [], -- ?? + mg_deps = noDependencies, -- ?? mg_exports = my_exports, mg_types = final_type_env, mg_insts = tcg_insts tcg_env, @@ -594,19 +607,25 @@ tcRnSrcDecls ds -- Type check the decls up to, but not including, the first splice (tcg_env, src_fvs1) <- tcRnGroup first_group ; - -- If there is no splice, we're done - case group_tail of - Nothing -> return (tcg_env, src_fvs1) - Just (splice_expr, rest_ds) -> do { - - setGblEnv tcg_env $ do { + -- Bale out if errors; for example, error recovery when checking + -- the RHS of 'main' can mean that 'main' is not in the envt for + -- the subsequent checkMain test + failIfErrsM ; + -- If there is no splice, we're done + case group_tail of { + Nothing -> return (tcg_env, src_fvs1) ; + Just (SpliceDecl splice_expr splice_loc, rest_ds) -> #ifndef GHCI failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") #else + setGblEnv tcg_env $ do { + -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, fvs) <- initRn SourceMode (rnExpr splice_expr) ; - tcg_env <- importSupportingDecls fvs ; + (rn_splice_expr, fvs) <- initRn SourceMode $ + addSrcLoc splice_loc $ + rnExpr splice_expr ; + tcg_env <- importSupportingDecls (fvs `plusFV` templateHaskellNames) ; setGblEnv tcg_env $ do { -- Execute the splice @@ -616,9 +635,9 @@ tcRnSrcDecls ds (tcg_env, src_fvs2) <- tcRnSrcDecls (spliced_decls ++ rest_ds) ; return (tcg_env, src_fvs1 `plusFV` src_fvs2) - } + }} #endif /* GHCI */ - }}} + }} \end{code} @@ -685,15 +704,9 @@ rnTopSrcDecls group ------------------------------------------------ tcTopSrcDecls :: HsGroup Name -> TcM TcGblEnv tcTopSrcDecls rn_decls - = fixM (\ unf_env -> do { - -- Loop back the final environment, including the fully zonked - -- versions of bindings from this module. In the presence of mutual - -- recursion, interface type signatures may mention variables defined - -- in this module, which is why the knot is so big - - -- Do the main work - ((tcg_env, binds, rules, fords), lie) <- getLIE ( - tc_src_decls unf_env rn_decls + = do { -- Do the main work + ((tcg_env, lcl_env, binds, rules, fords), lie) <- getLIE ( + tc_src_decls rn_decls ) ; -- tcSimplifyTop deals with constant or ambiguous InstIds. @@ -703,24 +716,29 @@ tcTopSrcDecls rn_decls -- type. (Usually, ambiguous type variables are resolved -- during the generalisation step.) traceTc (text "Tc8") ; - inst_binds <- setGblEnv tcg_env (tcSimplifyTop lie) ; + inst_binds <- setGblEnv tcg_env $ + setLclTypeEnv lcl_env $ + tcSimplifyTop lie ; -- The setGblEnv exposes the instances to tcSimplifyTop + -- The setLclTypeEnv exposes the local Ids, so that + -- we get better error messages (monomorphism restriction) -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. traceTc (text "Tc9") ; - (ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds) - rules fords ; + (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds) + rules fords ; - let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids, + let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) + bind_ids, tcg_binds = tcg_binds tcg_env `andMonoBinds` binds', tcg_rules = tcg_rules tcg_env ++ rules', tcg_fords = tcg_fords tcg_env ++ fords' } } ; return tcg_env' - }) + } -tc_src_decls unf_env +tc_src_decls (HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls, @@ -728,8 +746,9 @@ tc_src_decls unf_env hs_ruleds = rule_decls, hs_valds = val_binds }) = do { -- Type-check the type and class decls, and all imported decls + -- The latter come in via tycl_decls traceTc (text "Tc2") ; - tcg_env <- tcTyClDecls unf_env tycl_decls ; + tcg_env <- tcTyClDecls tycl_decls ; setGblEnv tcg_env $ do { -- Source-language instances, including derivings, @@ -789,13 +808,12 @@ tc_src_decls unf_env cls_dm_binds `AndMonoBinds` foe_binds } ; - return (tcg_env, all_binds, src_rules, foe_decls) + return (tcg_env, lcl_env, all_binds, src_rules, foe_decls) }}}}}}}}} \end{code} \begin{code} -tcTyClDecls :: RecTcGblEnv - -> [RenamedTyClDecl] +tcTyClDecls :: [RenamedTyClDecl] -> TcM TcGblEnv -- tcTyClDecls deals with @@ -806,11 +824,7 @@ tcTyClDecls :: RecTcGblEnv -- persistent compiler state to reflect the things imported from -- other modules -tcTyClDecls unf_env tycl_decls - -- (unf_env :: RecTcGblEnv) is used for type-checking interface pragmas - -- which is done lazily [ie failure just drops the pragma - -- without having any global-failure effect]. - +tcTyClDecls tycl_decls = checkNoErrs $ -- tcTyAndClassDecls recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade @@ -818,18 +832,12 @@ tcTyClDecls unf_env tycl_decls traceTc (text "TyCl1") `thenM_` tcTyAndClassDecls tycl_decls `thenM` \ tycl_things -> tcExtendGlobalEnv tycl_things $ - - -- Interface type signatures - -- We tie a knot so that the Ids read out of interfaces are in scope - -- when we read their pragmas. - -- What we rely on is that pragmas are typechecked lazily; if - -- any type errors are found (ie there's an inconsistency) - -- we silently discard the pragma - traceTc (text "TyCl2") `thenM_` - tcInterfaceSigs unf_env tycl_decls `thenM` \ sig_ids -> - tcExtendGlobalValEnv sig_ids $ - - getGblEnv -- Return the TcLocals environment + + traceTc (text "TyCl2") `thenM_` + tcInterfaceSigs tycl_decls `thenM` \ tcg_env -> + -- Returns the extended environment + + returnM tcg_env \end{code} @@ -923,13 +931,13 @@ typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv -- That is why the tcExtendX functions need to do partitioning. -- -- If all the decls are from other modules, the returned TcGblEnv - -- will have an empty tc_genv, but its tc_inst_env and tc_ist - -- caches may have been augmented. + -- will have an empty tc_genv, but its tc_inst_env + -- cache may have been augmented. typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_ruleds = rule_decls }) = do { -- Typecheck the type, class, and interface-sig decls - tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ; + tcg_env <- tcTyClDecls tycl_decls ; setGblEnv tcg_env $ do { -- Typecheck the instance decls, and rules @@ -1070,14 +1078,16 @@ check_main ghci_mode tcg_env | mod_name /= mAIN_Name = return (tcg_env, emptyFVs) + -- Check that 'main' is in scope + -- It might be imported from another module! + -- + -- We use a guard for this (rather than letting lookupSrcName fail) + -- because it's not an error in ghci) | not (main_RDR_Unqual `elemRdrEnv` rdr_env) = do { complain_no_main; return (tcg_env, emptyFVs) } | otherwise - = do { -- Check that 'main' is in scope - -- It might be imported from another module! - main_name <- lookupSrcName main_RDR_Unqual ; - failIfErrsM ; + = do { main_name <- lookupSrcName main_RDR_Unqual ; tcg_env <- importSupportingDecls (unitFV runIOName) ; setGblEnv tcg_env $ do { @@ -1107,15 +1117,11 @@ check_main ghci_mode tcg_env mod_name = moduleName (tcg_mod tcg_env) rdr_env = tcg_rdr_env tcg_env - main_RDR_Unqual :: RdrName - main_RDR_Unqual = mkUnqual varName FSLIT("main") - -- Don't get a RdrName from PrelNames.mainName, because - -- nameRdrNamegets an Orig RdrName, and we want a Qual or Unqual one. - -- An Unqual one will do just fine - complain_no_main | ghci_mode == Interactive = return () - | otherwise = addErr noMainMsg + | 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 'main'") noMainMsg = ptext SLIT("No 'main' defined in module Main") @@ -1164,11 +1170,14 @@ tcCoreDump mod_guts pprTcGblEnv :: TcGblEnv -> SDoc pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, tcg_insts = dfun_ids, - tcg_rules = rules }) + tcg_rules = rules, + tcg_imports = imports }) = vcat [ ppr_types dfun_ids type_env , ppr_insts dfun_ids , vcat (map ppr rules) - , ppr_gen_tycons (typeEnvTyCons type_env)] + , ppr_gen_tycons (typeEnvTyCons type_env) + , ppr (moduleEnvElts (imp_dep_mods imports)) + , ppr (imp_dep_pkgs imports)] pprModGuts :: ModGuts -> SDoc pprModGuts (ModGuts { mg_types = type_env,