X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=d225b6c167bab940cb9a14aac9f782bc0c86356d;hb=42b63073fb5e71fcd539ab80289cf6cf2a5b9641;hp=d4553d61632914351fbf48fdce5999e0668910d3;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index d4553d6..d225b6c 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -8,33 +8,41 @@ module TcRnDriver ( #ifdef GHCI mkGlobalContext, getModuleContents, #endif - tcRnModule, checkOldIface, importSupportingDecls, + tcRnModule, checkOldIface, + importSupportingDecls, tcTopSrcDecls, tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing ) where #include "HsVersions.h" +#ifdef GHCI +import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) +import DsMeta ( templateHaskellNames ) +#endif + import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) -import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..), - Stmt(..), Pat(VarPat), HsMatchContext(..), HsDoContext(..), RuleDecl(..), +import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), + Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..), + HsGroup(..), SpliceDecl(..), mkSimpleMatch, placeHolderType, toHsType, andMonoBinds, - isSrcRule + isSrcRule, collectStmtsBinders ) -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr ) +import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr, + emptyGroup, mkGroup, findSplice, addImpDecls ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, returnIOName, bindIOName, failIOName, thenIOName, runIOName, 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, - zonkTopExpr, zonkIdBndr + zonkTopExpr, zonkTopBndrs ) import TcExpr ( tcExpr_id ) @@ -49,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, @@ -63,15 +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, +import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv, ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs ) import RnExpr ( rnStmts, rnExpr ) -import RnSource ( rnSrcDecls, rnExtCoreDecls, checkModDeprec, rnStats ) +import RnSource ( rnSrcDecls, checkModDeprec, rnStats ) -import OccName ( varName ) import CoreUnfold ( unfoldingTemplate ) import CoreSyn ( IdCoreRule, Bind(..) ) import PprCore ( pprIdRules, pprCoreBindings ) @@ -80,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 @@ -92,7 +99,7 @@ import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), ModIface, ModDetails(..), ModGuts(..), HscEnv(..), ModIface(..), ModDetails(..), IfaceDecls(..), - GhciMode(..), + GhciMode(..), noDependencies, Deprecations(..), plusDeprecs, emptyGlobalRdrEnv, GenAvailInfo(Avail), availsToNameSet, @@ -104,7 +111,7 @@ import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), #ifdef GHCI import RdrName ( rdrEnvElts ) import RnHiFiles ( loadInterface ) -import RnEnv ( mkGlobalRdrEnv, plusGlobalRdrEnv ) +import RnEnv ( mkGlobalRdrEnv ) import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..), isLocalGRE ) #endif @@ -137,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 @@ -164,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 @@ -213,7 +223,7 @@ tcRnIface hsc_env pcs -- Get the supporting decls, and typecheck them all together -- so that any mutually recursive types are done right extra_decls <- slurpImpDecls needed ; - env <- typecheckIfaceDecls (decls ++ extra_decls) ; + env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ; returnM (ModDetails { md_types = tcg_type_env env, md_insts = tcg_insts env, @@ -224,9 +234,9 @@ tcRnIface hsc_env pcs rule_decls = dcl_rules iface_decls inst_decls = dcl_insts iface_decls tycl_decls = dcl_tycl iface_decls - decls = map RuleD rule_decls ++ - map InstD inst_decls ++ - map TyClD tycl_decls + group = emptyGroup { hs_ruleds = rule_decls, + hs_instds = inst_decls, + hs_tyclds = tycl_decls } needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets` unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets` unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets` @@ -253,16 +263,19 @@ 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 $ setInteractiveContext ictxt $ do { -- Rename; use CmdLineMode because tcRnStmt is only used interactively - ((bound_names, [rn_stmt]), fvs) <- initRnInteractive ictxt - (rnStmts [rdr_stmt]) ; + ([rn_stmt], fvs) <- initRnInteractive ictxt + (rnStmts DoExpr [rdr_stmt]) ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; failIfErrsM ; @@ -281,7 +294,7 @@ tcRnStmt hsc_env pcs ictxt rdr_stmt setGblEnv tcg_env $ do { -- The real work is done here - ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt bound_names rn_stmt) ; + ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt rn_stmt) ; traceTc (text "tcs 1") ; let { -- Make all the bound ids "global" ids, now that @@ -344,35 +357,34 @@ Here is the grand plan, implemented in tcUserStmt \begin{code} --------------------------- -tcUserStmt :: [Name] -> RenamedStmt -> TcM ([Id], TypecheckedHsExpr) -tcUserStmt names (ExprStmt expr _ loc) - = ASSERT( null names ) - newUnique `thenM` \ uniq -> +tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr) +tcUserStmt (ExprStmt expr _ loc) + = newUnique `thenM` \ uniq -> let fresh_it = itName uniq the_bind = FunMonoBind fresh_it False [ mkSimpleMatch [] expr placeHolderType loc ] loc in - tryTc_ (do { -- Try this if the other fails + tryTcLIE_ (do { -- Try this if the other fails traceTc (text "tcs 1b") ; - tc_stmts [fresh_it] [ + tc_stmts [ LetStmt (MonoBind the_bind [] NonRecursive), ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) placeHolderType loc] }) (do { -- Try this first traceTc (text "tcs 1a") ; - tc_stmts [fresh_it] [BindStmt (VarPat fresh_it) expr loc] }) + tc_stmts [BindStmt (VarPat fresh_it) expr loc] }) -tcUserStmt names stmt - = tc_stmts names [stmt] +tcUserStmt stmt = tc_stmts [stmt] --------------------------- -tc_stmts names stmts +tc_stmts stmts = do { io_ids <- mappM tcLookupId [returnIOName, failIOName, bindIOName, thenIOName] ; ioTyCon <- tcLookupTyCon ioTyConName ; res_ty <- newTyVarTy liftedTypeKind ; let { + names = collectStmtsBinders stmts ; return_id = head io_ids ; -- Rather gruesome io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ; @@ -388,7 +400,7 @@ tc_stmts names stmts -- OK, we're ready to typecheck the stmts traceTc (text "tcs 2") ; ((ids, tc_stmts), lie) <- - getLIE $ tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts $ + getLIE $ tcStmtsAndThen combine DoExpr io_ty stmts $ do { -- Look up the names right in the middle, -- where they will all be in scope @@ -399,7 +411,7 @@ tc_stmts names stmts -- Simplify the context right here, so that we fail -- if there aren't enough instances. Notably, when we see -- e - -- we use tryTc_ to try it <- e + -- we use recoverTc_ to try it <- e -- and then let it = e -- It's the simplify step that rejects the first. traceTc (text "tcs 3") ; @@ -410,7 +422,7 @@ tc_stmts names stmts HsDo DoExpr tc_stmts io_ids (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ; zonked_expr <- zonkTopExpr expr ; - zonked_ids <- mappM zonkIdBndr ids ; + zonked_ids <- zonkTopBndrs ids ; return (zonked_ids, zonked_expr) } @@ -472,16 +484,23 @@ tcRnThing hsc_env pcs ictxt rdr_name let { rdr_names = dataTcOccs rdr_name } ; (msgs_s, mb_names) <- initRnInteractive ictxt - (mapAndUnzipM (tryM . lookupOccRn) rdr_names) ; + (mapAndUnzipM (tryTc . lookupOccRn) rdr_names) ; let { names = catMaybes mb_names } ; if null names then 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} @@ -524,18 +543,19 @@ tcRnExtCore hsc_env pcs -- Rename the source, only in interface mode. -- rnSrcDecls handles fixity decls etc too, which won't occur -- but that doesn't matter - (rn_local_decls, fvs) <- initRn (InterfaceMode this_mod) - (rnExtCoreDecls local_decls) ; + let { local_group = mkGroup local_decls } ; + (_, rn_local_decls, fvs) <- initRn (InterfaceMode this_mod) + (rnSrcDecls local_group) ; failIfErrsM ; -- Get the supporting decls, and typecheck them all together -- so that any mutually recursive types are done right extra_decls <- slurpImpDecls fvs ; - tcg_env <- typecheckIfaceDecls (rn_local_decls ++ extra_decls) ; + tcg_env <- typecheckIfaceDecls (rn_local_decls `addImpDecls` extra_decls) ; setGblEnv tcg_env $ do { -- Now the core bindings - core_prs <- tcCoreBinds [d | CoreD d <- rn_local_decls] ; + core_prs <- tcCoreBinds (hs_coreds rn_local_decls) ; tcExtendGlobalValEnv (map fst core_prs) $ do { -- Wrap up @@ -549,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, @@ -575,38 +596,49 @@ tcRnExtCore hsc_env pcs %* * %************************************************************************ +\begin{code} tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars) -- Returns the variables free in the decls -tcRnSrcDecls [] = getGblEnv + -- Reason: solely to report unused imports and bindings +tcRnSrcDecls [] = do { tcg_env <- getGblEnv ; return (tcg_env, emptyFVs) } tcRnSrcDecls ds = do { let { (first_group, group_tail) = findSplice ds } ; - tcg_env <- tcRnGroup first_group ; + -- Type check the decls up to, but not including, the first splice + (tcg_env, src_fvs1) <- tcRnGroup first_group ; - case group_tail of - Nothing -> return gbl_env - Just (splice_expr, rest_ds) -> 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 spliced_decls <- tcSpliceDecls rn_splice_expr ; -- Glue them on the front of the remaining decls and loop - tcRnSrcDeclsDecls (splice_decls ++ rest_ds) - }}}} + (tcg_env, src_fvs2) <- tcRnSrcDecls (spliced_decls ++ rest_ds) ; -findSplice :: [HsDecl a] -> ([HsDecl a], Maybe (HsExpr a, [HsDecl a])) -findSplice [] = ([], Nothing) -findSplice (SpliceD e : ds) = ([], Just (e, ds)) -findSplice (d : ds) = (d:gs, rest) - where - (gs, rest) = findSplice ds + return (tcg_env, src_fvs1 `plusFV` src_fvs2) + }} +#endif /* GHCI */ + }} +\end{code} %************************************************************************ @@ -615,7 +647,7 @@ findSplice (d : ds) = (d:gs, rest) %* * %************************************************************************ -tcRnSrcDecls takes a bunch of top-level source-code declarations, and +tcRnGroup takes a bunch of top-level source-code declarations, and * renames them * gets supporting declarations from interface files * typechecks them @@ -627,9 +659,9 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars) +tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, FreeVars) -- Returns the variables free in the decls -tcRnSrcDecls decls +tcRnGroup decls = do { -- Rename the declarations (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { @@ -640,36 +672,41 @@ tcRnSrcDecls decls }} ------------------------------------------------ -rnTopSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, [RenamedHsDecl], FreeVars) -rnTopSrcDecls decls - = do { (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls decls) ; +rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, FreeVars) +rnTopSrcDecls group + = do { -- Bring top level binders into scope + (rdr_env, imports) <- importsFromLocalDecls group ; + updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` + tcg_rdr_env gbl, + tcg_imports = imports `plusImportAvails` + tcg_imports gbl }) + $ do { + + failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations + + -- Rename the source decls + (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls group) ; setGblEnv tcg_env $ do { failIfErrsM ; -- Import consquential imports rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ; - let { rn_decls = rn_src_decls ++ rn_imp_decls } ; + let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; -- Dump trace of renaming part - rnDump (vcat (map ppr rn_decls)) ; + rnDump (ppr rn_decls) ; rnStats rn_imp_decls ; return (tcg_env, rn_decls, src_fvs) - }} + }}} ------------------------------------------------ -tcTopSrcDecls :: [RenamedHsDecl] -> TcM TcGblEnv +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. @@ -679,27 +716,39 @@ 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 decls +tc_src_decls + (HsGroup { hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + 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, @@ -713,14 +762,14 @@ tc_src_decls unf_env decls -- Foreign import declarations next. No zonking necessary -- here; we can tuck them straight into the global environment. traceTc (text "Tc4") ; - (fi_ids, fi_decls) <- tcForeignImports decls ; + (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; tcExtendGlobalValEnv fi_ids $ updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls }) $ do { -- Default declarations traceTc (text "Tc4a") ; - default_tys <- tcDefaults decls ; + default_tys <- tcDefaults default_decls ; updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { -- Value declarations next @@ -741,7 +790,7 @@ tc_src_decls unf_env decls -- Foreign exports -- They need to be zonked, so we return them traceTc (text "Tc7") ; - (foe_binds, foe_decls) <- tcForeignExports decls ; + (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; -- Rules -- Need to partition them because the source rules @@ -759,19 +808,12 @@ tc_src_decls unf_env decls 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) }}}}}}}}} - where - tycl_decls = [d | TyClD d <- decls] - rule_decls = [d | RuleD d <- decls] - inst_decls = [d | InstD d <- decls] - val_decls = [d | ValD d <- decls] - val_binds = foldr ThenBinds EmptyBinds val_decls \end{code} \begin{code} -tcTyClDecls :: RecTcGblEnv - -> [RenamedTyClDecl] +tcTyClDecls :: [RenamedTyClDecl] -> TcM TcGblEnv -- tcTyClDecls deals with @@ -782,30 +824,21 @@ 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 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 + tcTyAndClassDecls tycl_decls `thenM` \ tcg_env -> + -- Returns the extended environment + setGblEnv tcg_env $ + + traceTc (text "TyCl2") `thenM_` + tcInterfaceSigs tycl_decls `thenM` \ tcg_env -> + -- Returns the extended environment + + returnM tcg_env \end{code} @@ -889,9 +922,9 @@ importSupportingDecls fvs = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ; decls <- slurpImpDecls fvs ; traceRn (text "...namely:" <+> vcat (map ppr decls)) ; - typecheckIfaceDecls decls } + typecheckIfaceDecls (mkGroup decls) } -typecheckIfaceDecls :: [RenamedHsDecl] -> TcM TcGblEnv +typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv -- The decls are all interface-file declarations -- Usually they are all from other modules, but when we are reading -- this module's interface from a file, it's possible that some of @@ -899,15 +932,13 @@ typecheckIfaceDecls :: [RenamedHsDecl] -> 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. -typecheckIfaceDecls decls - = do { let { tycl_decls = [d | TyClD d <- decls] ; - inst_decls = [d | InstD d <- decls] ; - rule_decls = [d | RuleD d <- decls] } ; - - -- Typecheck the type, class, and interface-sig decls - tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ; + -- 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 <- tcTyClDecls tycl_decls ; setGblEnv tcg_env $ do { -- Typecheck the instance decls, and rules @@ -1048,14 +1079,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 { @@ -1085,15 +1118,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") @@ -1142,11 +1171,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,