X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=52ac93b5f126d4d65f83bf562002afb968c917ca;hb=4e3255388e8b99ccdae290bfcb6cd666b8c93d4a;hp=016e405819784cc3ea29b72bfc37a80af345aceb;hpb=d32c5227315009f38355fe3233f0f4e5b1f61dc6;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 016e405..52ac93b 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -7,7 +7,7 @@ module TcRnDriver ( #ifdef GHCI mkExportEnv, getModuleContents, tcRnStmt, - tcRnThing, tcRnExpr, tcRnType, + tcRnGetInfo, tcRnExpr, tcRnType, #endif tcRnModule, tcTopSrcDecls, @@ -41,7 +41,7 @@ import TcEnv ( tcExtendGlobalValEnv ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcIface ( tcExtCoreBindings ) +import TcIface ( tcExtCoreBindings, loadImportedInsts ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import LoadIface ( loadOrphanModules ) @@ -61,11 +61,11 @@ import NameSet import TyCon ( tyConHasGenerics ) import SrcLoc ( SrcLoc, srcLocSpan, Located(..), noLoc ) import Outputable -import HscTypes ( ModGuts(..), HscEnv(..), - GhciMode(..), Dependencies(..), noDependencies, +import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState( eps_is_boot ), + GhciMode(..), isOneShot, Dependencies(..), noDependencies, Deprecs( NoDeprecs ), plusDeprecs, ForeignStubs(NoStubs), TypeEnv, - extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, + extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, emptyFixityEnv ) #ifdef GHCI @@ -83,21 +83,23 @@ import TcExpr ( tcCheckRho ) import TcMType ( zonkTcType ) import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) -import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType ) +import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, tyClsNamesOfDFunHead ) import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) import RnTypes ( rnLHsType ) -import Inst ( tcStdSyntaxName ) +import Inst ( tcStdSyntaxName, tcGetInstEnvs ) +import InstEnv ( DFunId, classInstances, instEnvElts ) import RnExpr ( rnStmts, rnLExpr ) import RnNames ( exportsToAvails ) import LoadIface ( loadSrcInterface ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), - IfaceExtName(..), IfaceConDecls(..), - tyThingToIfaceDecl ) + IfaceExtName(..), IfaceConDecls(..), IfaceInst(..), + tyThingToIfaceDecl, dfunToIfaceInst ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) import Id ( Id, isImplicitId, globalIdDetails ) import FieldLabel ( fieldLabelTyCon ) import MkId ( unsafeCoerceId ) import DataCon ( dataConTyCon ) +import TyCon ( tyConName ) import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) import SrcLoc ( interactiveSrcLoc, unLoc ) @@ -107,8 +109,8 @@ import Name ( nameOccName, nameModuleName ) import NameEnv ( delListFromNameEnv ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName ) import Module ( ModuleName, lookupModuleEnvByName ) -import HscTypes ( InteractiveContext(..), - HomeModInfo(..), typeEnvElts, +import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ), + HomeModInfo(..), typeEnvElts, typeEnvClasses, TyThing(..), availName, availNames, icPrintUnqual, ModIface(..), ModDetails(..) ) import BasicTypes ( RecFlag(..), Fixity ) @@ -152,6 +154,12 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports addSrcSpan loc $ do { -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; + + -- In one-shot mode, record boot-file info in the EPS + ifM (isOneShot (hsc_mode hsc_env)) $ + updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ; + + -- Update the gbl env updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports }) $ do { @@ -219,641 +227,642 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports %************************************************************************ %* * - The interactive interface + Type-checking external-core modules %* * %************************************************************************ \begin{code} -#ifdef GHCI -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] - -- - -- The returned TypecheckedHsExpr is of type IO [ () ], - -- a list of the bound values, coerced to (). +tcRnExtCore :: HscEnv + -> HsExtCore RdrName + -> IO (Messages, Maybe ModGuts) + -- Nothing => some error occurred -tcRnStmt hsc_env ictxt rdr_stmt - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext ictxt $ do { +tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) + -- The decls are IfaceDecls; all names are original names + = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - -- Rename; use CmdLineMode because tcRnStmt is only used interactively - ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ; - traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; - failIfErrsM ; - - -- The real work is done here - (bound_ids, tc_expr) <- tcUserStmt rn_stmt ; - - traceTc (text "tcs 1") ; - let { -- 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. - global_ids = map (globaliseId VanillaGlobal) bound_ids ; - - -- Update the interactive context - rn_env = ic_rn_local_env ictxt ; - type_env = ic_type_env ictxt ; + initTc hsc_env this_mod $ do { - bound_names = map idName global_ids ; - new_rn_env = extendLocalRdrEnv rn_env bound_names ; + let { ldecls = map noLoc decls } ; - -- Remove any shadowed bindings from the type_env; - -- they are inaccessible but might, I suppose, cause - -- a space leak if we leave them there - shadowed = [ n | name <- bound_names, - let rdr_name = mkRdrUnqual (nameOccName name), - Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ; + -- Deal with the type declarations; first bring their stuff + -- into scope, then rname them, then type check them + (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ; - filtered_type_env = delListFromNameEnv type_env shadowed ; - new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ; + updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl, + tcg_imports = imports `plusImportAvails` tcg_imports gbl }) + $ do { - new_ic = ictxt { ic_rn_local_env = new_rn_env, - ic_type_env = new_type_env } - } ; + rn_decls <- rnTyClDecls ldecls ; + failIfErrsM ; - dumpOptTcRn Opt_D_dump_tc - (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, - text "Typechecked expr" <+> ppr tc_expr]) ; + -- Dump trace of renaming part + rnDump (ppr rn_decls) ; - returnM (new_ic, bound_names, tc_expr) - } -\end{code} + -- Typecheck them all together so that + -- any mutually recursive types are done right + tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ; + -- Make the new type env available to stuff slurped from interface files + setGblEnv tcg_env $ do { + + -- Now the core bindings + core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ; -Here is the grand plan, implemented in tcUserStmt + -- Wrap up + let { + bndrs = bindersOfBinds core_binds ; + my_exports = mkNameSet (map idName bndrs) ; + -- ToDo: export the data types also? - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] + final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] + 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, + mg_rules = [], + mg_binds = core_binds, - expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] - [NB: result not printed] bindings: [it] - - expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] - result showable) bindings: [it] + -- Stubs + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_deprecs = NoDeprecs, + mg_foreign = NoStubs + } } ; - expr (of non-IO type, - result not showable) ==> error + tcCoreDump mod_guts ; + return mod_guts + }}}} -\begin{code} ---------------------------- -tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id) -tcUserStmt (L _ (ExprStmt expr _)) - = newUnique `thenM` \ uniq -> - let - fresh_it = itName uniq - the_bind = noLoc $ FunBind (noLoc fresh_it) False - [ mkSimpleMatch [] expr placeHolderType ] - in - tryTcLIE_ (do { -- Try this if the other fails - traceTc (text "tcs 1b") ; - tc_stmts [ - nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive], - nlExprStmt (nlHsApp (nlHsVar printName) - (nlHsVar fresh_it)) - ] }) - (do { -- Try this first - traceTc (text "tcs 1a") ; - tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] }) +mkFakeGroup decls -- Rather clumsy; lots of unused fields + = HsGroup { hs_tyclds = decls, -- This is the one we want + hs_valds = [], hs_fords = [], + hs_instds = [], hs_fixds = [], hs_depds = [], + hs_ruleds = [], hs_defds = [] } +\end{code} -tcUserStmt stmt = tc_stmts [stmt] ---------------------------- -tc_stmts stmts - = do { ioTyCon <- tcLookupTyCon ioTyConName ; - let { - ret_ty = mkListTy unitTy ; - io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; +%************************************************************************ +%* * + Type-checking the top level of a module +%* * +%************************************************************************ - names = map unLoc (collectStmtsBinders stmts) ; +\begin{code} +tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv + -- Returns the variables free in the decls + -- Reason: solely to report unused imports and bindings +tcRnSrcDecls decls + = do { -- Do all the declarations + (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ; - stmt_ctxt = SC { sc_what = DoExpr, - sc_rhs = check_rhs, - sc_body = check_body, - sc_ty = ret_ty } ; + -- tcSimplifyTop deals with constant or ambiguous InstIds. + -- How could there be ambiguous ones? They can only arise if a + -- top-level decl falls under the monomorphism + -- restriction, and no subsequent decl instantiates its + -- type. (Usually, ambiguous type variables are resolved + -- during the generalisation step.) + traceTc (text "Tc8") ; + inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ; + -- Setting the global env exposes the instances to tcSimplifyTop + -- Setting the local env exposes the local Ids to tcSimplifyTop, + -- so that we get better error messages (monomorphism restriction) - check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ; - check_body body = tcCheckRho body io_ret_ty ; + -- Backsubstitution. This must be done last. + -- Even tcSimplifyTop may do some unification. + traceTc (text "Tc9") ; + let { (tcg_env, _) = tc_envs ; + TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, + tcg_rules = rules, tcg_fords = fords } = tcg_env } ; - -- mk_return builds the expression - -- returnIO @ [()] [coerce () x, .., coerce () z] - -- - -- Despite the inconvenience of building the type applications etc, - -- this *has* to be done in type-annotated post-typecheck form - -- because we are going to return a list of *polymorphic* values - -- coerced to type (). If we built a *source* stmt - -- return [coerce x, ..., coerce z] - -- then the type checker would instantiate x..z, and we wouldn't - -- get their *polymorphic* values. (And we'd get ambiguity errs - -- if they were overloaded, since they aren't applied to anything.) - mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty]) - (noLoc $ ExplicitList unitTy (map mk_item ids)) ; - mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy]) - (nlHsVar id) ; + (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) + rules fords ; - io_ty = mkTyConApp ioTyCon [] - } ; + let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ; - -- OK, we're ready to typecheck the stmts - traceTc (text "tcs 2") ; - ((ids, tc_expr), lie) <- getLIE $ do { - (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $ - do { - -- Look up the names right in the middle, - -- where they will all be in scope - ids <- mappM tcLookupId names ; - ret_id <- tcLookupId returnIOName ; -- return @ IO - return (ids, [nlResultStmt (mk_return ret_id ids)]) } ; + -- Make the new type env available to stuff slurped from interface files + writeMutVar (tcg_type_env_var tcg_env) final_type_env ; - io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ; - return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty)) - } ; + return (tcg_env { tcg_type_env = final_type_env, + tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }) + } - -- Simplify the context right here, so that we fail - -- if there aren't enough instances. Notably, when we see - -- 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") ; - const_binds <- tcSimplifyInteractive lie ; +tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) +-- Loops around dealing with each top level inter-splice group +-- in turn, until it's dealt with the entire module +tc_rn_src_decls ds + = do { let { (first_group, group_tail) = findSplice ds } ; + -- If ds is [] we get ([], Nothing) - -- Build result expression and zonk it - let { expr = mkHsLet const_binds tc_expr } ; - zonked_expr <- zonkTopLExpr expr ; - zonked_ids <- zonkTopBndrs ids ; + -- Type check the decls up to, but not including, the first splice + tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ; - -- 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) ; + -- 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 ; - return (zonked_ids, zonked_expr) - } - where - combine stmt (ids, stmts) = (ids, stmt:stmts) - bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), - nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) + setEnvs tc_envs $ + + -- If there is no splice, we're nearly done + case group_tail of { + Nothing -> do { -- Last thing: check for `main' + tcg_env <- checkMain ; + return (tcg_env, tcl_env) + } ; + + -- If there's a splice, we must carry on + Just (SpliceDecl splice_expr, rest_ds) -> do { +#ifndef GHCI + failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") +#else + + -- Rename the splice expression, and get its supporting decls + (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ; + failIfErrsM ; -- Don't typecheck if renaming failed + + -- Execute the splice + spliced_decls <- tcSpliceDecls rn_splice_expr ; + + -- Glue them on the front of the remaining decls and loop + setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + tc_rn_src_decls (spliced_decls ++ rest_ds) +#endif /* GHCI */ + }}} \end{code} -tcRnExpr just finds the type of an expression +%************************************************************************ +%* * + Type-checking the top level of a module +%* * +%************************************************************************ + +tcRnGroup takes a bunch of top-level source-code declarations, and + * renames them + * gets supporting declarations from interface files + * typechecks them + * zonks them + * and augments the TcGblEnv with the results + +In Template Haskell it may be called repeatedly for each group of +declarations. It expects there to be an incoming TcGblEnv in the +monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnExpr :: HscEnv - -> InteractiveContext - -> LHsExpr RdrName - -> IO (Maybe Type) -tcRnExpr hsc_env ictxt rdr_expr - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext ictxt $ do { +tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) + -- Returns the variables free in the decls, for unused-binding reporting +tcRnGroup decls + = do { -- Rename the declarations + (tcg_env, rn_decls) <- rnTopSrcDecls decls ; + setGblEnv tcg_env $ do { - (rn_expr, fvs) <- rnLExpr rdr_expr ; - failIfErrsM ; + -- Typecheck the declarations + tcTopSrcDecls rn_decls + }} - -- Now typecheck the expression; - -- it might have a rank-2 type (e.g. :t runST) - ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; - ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; - tcSimplifyInteractive lie_top ; +------------------------------------------------ +rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) +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 { - let { all_expr_ty = mkForAllTys qtvs $ - mkFunTys (map idType dict_ids) $ - res_ty } ; - zonkTcType all_expr_ty - } - where - smpl_doc = ptext SLIT("main expression") -\end{code} + traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ; + failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations -tcRnExpr just finds the kind of a type + -- Rename the source decls + (tcg_env, rn_decls) <- rnSrcDecls group ; + failIfErrsM ; -\begin{code} -tcRnType :: HscEnv - -> InteractiveContext - -> LHsType RdrName - -> IO (Maybe Kind) -tcRnType hsc_env ictxt rdr_type - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext ictxt $ do { + -- Dump trace of renaming part + rnDump (ppr rn_decls) ; - rn_type <- rnLHsType doc rdr_type ; - failIfErrsM ; + return (tcg_env, rn_decls) + }} - -- Now kind-check the type - (ty', kind) <- kcHsType rn_type ; - return kind - } - where - doc = ptext SLIT("In GHCi input") -\end{code} +------------------------------------------------ +tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls + (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") ; -\begin{code} -tcRnThing :: HscEnv - -> InteractiveContext - -> RdrName - -> IO (Maybe [(IfaceDecl, Fixity, SrcLoc)]) --- Look up a RdrName and return all the TyThings it might be --- A capitalised RdrName is given to us in the DataName namespace, --- but we want to treat it as *both* a data constructor --- *and* as a type or class constructor; --- hence the call to dataTcOccs, and we return up to two results -tcRnThing hsc_env ictxt rdr_name - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext ictxt $ do { + tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ; + -- tcTyAndClassDecls recovers internally, but if anything gave rise to + -- an error we'd better stop now, to avoid a cascade + + -- 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) ; - -- If the identifier is a constructor (begins with an - -- upper-case letter), then we need to consider both - -- constructor and type class identifiers. - let { rdr_names = dataTcOccs rdr_name } ; - -- results :: [(Messages, Maybe Name)] - results <- mapM (tryTc . lookupOccRn) rdr_names ; + setGblEnv tcg_env $ do { + -- Source-language instances, including derivings, + -- and import the supporting declarations + traceTc (text "Tc3") ; + (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ; + setGblEnv tcg_env $ do { - -- The successful lookups will be (Just name) - let { (warns_s, good_names) = unzip [ (msgs, name) - | (msgs, Just name) <- results] ; - errs_s = [msgs | (msgs, Nothing) <- results] } ; + -- 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 foreign_decls ; + tcExtendGlobalValEnv fi_ids $ do { - -- Fail if nothing good happened, else add warnings - if null good_names then - -- No lookup succeeded, so - -- pick the first error message and report it - -- ToDo: If one of the errors is "could be Foo.X or Baz.X", - -- while the other is "X is not in scope", - -- we definitely want the former; but we might pick the latter - do { addMessages (head errs_s) ; failM } - else -- Add deprecation warnings - mapM_ addMessages warns_s ; + -- Default declarations + traceTc (text "Tc4a") ; + default_tys <- tcDefaults default_decls ; + updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { - -- And lookup up the entities, avoiding duplicates, which arise - -- because constructors and record selectors are represented by - -- their parent declaration - let { do_one name = do { thing <- tcLookupGlobal name - ; let decl = toIfaceDecl ictxt thing - ; fixity <- lookupFixityRn name - ; return (decl, fixity, getSrcLoc thing) } ; - -- For the SrcLoc, the 'thing' has better info than - -- the 'name' because getting the former forced the - -- declaration to be loaded into the cache - cmp (d1,_,_) (d2,_,_) = ifName d1 `compare` ifName d2 } ; - results <- mapM do_one good_names ; - return (fst (removeDups cmp results)) - } + -- Value declarations next + -- We also typecheck any extra binds that came out + -- of the "deriving" process (deriv_binds) + traceTc (text "Tc5") ; + (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ; + setLclTypeEnv lcl_env $ do { -toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl -toIfaceDecl ictxt thing - = tyThingToIfaceDecl True -- Discard IdInfo - emptyNameSet -- Show data cons - ext_nm (munge thing) - where - unqual = icPrintUnqual ictxt - ext_nm n | unqual n = LocalTop (nameOccName n) -- What a hack - | otherwise = ExtPkg (nameModuleName n) (nameOccName n) + -- Second pass over class and instance declarations, + traceTc (text "Tc6") ; + (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ; + showLIE (text "after instDecls2") ; - -- munge transforms a thing to it's "parent" thing - munge (ADataCon dc) = ATyCon (dataConTyCon dc) - munge (AnId id) = case globalIdDetails id of - RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl) - ClassOpId cls -> AClass cls - other -> AnId id - munge other_thing = other_thing -\end{code} + -- Foreign exports + -- They need to be zonked, so we return them + traceTc (text "Tc7") ; + (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; + -- Rules + rules <- tcRules rule_decls ; -\begin{code} -setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a -setInteractiveContext icxt thing_inside - = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_` - (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt, - tcg_type_env = ic_type_env icxt}) $ - updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $ - thing_inside) -#endif /* GHCI */ + -- Wrap up + traceTc (text "Tc7a") ; + tcg_env <- getGblEnv ; + let { all_binds = tc_val_binds `unionBags` + inst_binds `unionBags` + foe_binds ; + + -- Extend the GblEnv with the (as yet un-zonked) + -- bindings, rules, foreign decls + tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds, + tcg_rules = tcg_rules tcg_env ++ rules, + tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; + return (tcg_env', lcl_env) + }}}}}} \end{code} + %************************************************************************ %* * - Type-checking external-core modules + Checking for 'main' %* * %************************************************************************ \begin{code} -tcRnExtCore :: HscEnv - -> HsExtCore RdrName - -> IO (Messages, Maybe ModGuts) - -- Nothing => some error occurred - -tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) - -- The decls are IfaceDecls; all names are original names - = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - - initTc hsc_env this_mod $ do { - - let { ldecls = map noLoc decls } ; +checkMain + = do { ghci_mode <- getGhciMode ; + tcg_env <- getGblEnv ; - -- Deal with the type declarations; first bring their stuff - -- into scope, then rname them, then type check them - (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ; + mb_main_mod <- readMutVar v_MainModIs ; + mb_main_fn <- readMutVar v_MainFunIs ; + let { main_mod = case mb_main_mod of { + Just mod -> mkModuleName mod ; + Nothing -> mAIN_Name } ; + main_fn = case mb_main_fn of { + Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ; + Nothing -> main_RDR_Unqual } } ; + + check_main ghci_mode tcg_env main_mod main_fn + } - updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl, - tcg_imports = imports `plusImportAvails` tcg_imports gbl }) - $ do { - rn_decls <- rnTyClDecls ldecls ; - failIfErrsM ; +check_main ghci_mode tcg_env main_mod main_fn + -- If we are in module Main, check that 'main' is defined. + -- It may be imported from another module! + -- + -- ToDo: We have to return the main_name separately, because it's a + -- bona fide 'use', and should be recorded as such, but the others + -- aren't + -- + -- Blimey: a whole page of code to do this... + | mod_name /= main_mod + = return tcg_env - -- Dump trace of renaming part - rnDump (ppr rn_decls) ; + | otherwise + = addErrCtxt mainCtxt $ + do { mb_main <- lookupSrcOcc_maybe main_fn + -- Check that 'main' is in scope + -- It might be imported from another module! + ; case mb_main of { + Nothing -> do { complain_no_main + ; return tcg_env } ; + Just main_name -> do + { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) } + -- :Main.main :: IO () = runIO main - -- Typecheck them all together so that - -- any mutually recursive types are done right - tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ; - -- Make the new type env available to stuff slurped from interface files + ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $ + tcInferRho rhs - setGblEnv tcg_env $ do { - - -- Now the core bindings - core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ; + ; let { root_main_id = mkExportedLocalId rootMainName ty ; + main_bind = noLoc (VarBind root_main_id main_expr) } - -- Wrap up - let { - bndrs = bindersOfBinds core_binds ; - my_exports = mkNameSet (map idName bndrs) ; - -- ToDo: export the data types also? + ; return (tcg_env { tcg_binds = tcg_binds tcg_env + `snocBag` main_bind, + tcg_dus = tcg_dus tcg_env + `plusDU` usesOnly (unitFV main_name) + }) + }}} + where + mod_name = moduleName (tcg_mod tcg_env) + + complain_no_main | ghci_mode == Interactive = 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. - final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; + 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) + <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) +\end{code} - 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, - mg_rules = [], - mg_binds = core_binds, - -- Stubs - mg_rdr_env = emptyGlobalRdrEnv, - mg_fix_env = emptyFixityEnv, - mg_deprecs = NoDeprecs, - mg_foreign = NoStubs - } } ; +%********************************************************* +%* * + GHCi stuff +%* * +%********************************************************* - tcCoreDump mod_guts ; +\begin{code} +#ifdef GHCI +setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a +setInteractiveContext icxt thing_inside + = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_` + (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt, + tcg_type_env = ic_type_env icxt}) $ + updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $ + thing_inside) +\end{code} - return mod_guts - }}}} -mkFakeGroup decls -- Rather clumsy; lots of unused fields - = HsGroup { hs_tyclds = decls, -- This is the one we want - hs_valds = [], hs_fords = [], - hs_instds = [], hs_fixds = [], hs_depds = [], - hs_ruleds = [], hs_defds = [] } -\end{code} +\begin{code} +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] + -- + -- The returned TypecheckedHsExpr is of type IO [ () ], + -- a list of the bound values, coerced to (). +tcRnStmt hsc_env ictxt rdr_stmt + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext ictxt $ do { -%************************************************************************ -%* * - Type-checking the top level of a module -%* * -%************************************************************************ + -- Rename; use CmdLineMode because tcRnStmt is only used interactively + ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ; + traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; + failIfErrsM ; + + -- The real work is done here + (bound_ids, tc_expr) <- tcUserStmt rn_stmt ; + + traceTc (text "tcs 1") ; + let { -- 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. + global_ids = map (globaliseId VanillaGlobal) bound_ids ; + + -- Update the interactive context + rn_env = ic_rn_local_env ictxt ; + type_env = ic_type_env ictxt ; -\begin{code} -tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv - -- Returns the variables free in the decls - -- Reason: solely to report unused imports and bindings -tcRnSrcDecls decls - = do { -- Do all the declarations - (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ; + bound_names = map idName global_ids ; + new_rn_env = extendLocalRdrEnv rn_env bound_names ; - -- tcSimplifyTop deals with constant or ambiguous InstIds. - -- How could there be ambiguous ones? They can only arise if a - -- top-level decl falls under the monomorphism - -- restriction, and no subsequent decl instantiates its - -- type. (Usually, ambiguous type variables are resolved - -- during the generalisation step.) - traceTc (text "Tc8") ; - inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ; - -- Setting the global env exposes the instances to tcSimplifyTop - -- Setting the local env exposes the local Ids to tcSimplifyTop, - -- so that we get better error messages (monomorphism restriction) + -- Remove any shadowed bindings from the type_env; + -- they are inaccessible but might, I suppose, cause + -- a space leak if we leave them there + shadowed = [ n | name <- bound_names, + let rdr_name = mkRdrUnqual (nameOccName name), + Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ; - -- Backsubstitution. This must be done last. - -- Even tcSimplifyTop may do some unification. - traceTc (text "Tc9") ; - let { (tcg_env, _) = tc_envs ; - TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, - tcg_rules = rules, tcg_fords = fords } = tcg_env } ; + filtered_type_env = delListFromNameEnv type_env shadowed ; + new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ; - (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) - rules fords ; + new_ic = ictxt { ic_rn_local_env = new_rn_env, + ic_type_env = new_type_env } + } ; - let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ; + dumpOptTcRn Opt_D_dump_tc + (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, + text "Typechecked expr" <+> ppr tc_expr]) ; - -- Make the new type env available to stuff slurped from interface files - writeMutVar (tcg_type_env_var tcg_env) final_type_env ; + returnM (new_ic, bound_names, tc_expr) + } +\end{code} - return (tcg_env { tcg_type_env = final_type_env, - tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }) - } -tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) --- Loops around dealing with each top level inter-splice group --- in turn, until it's dealt with the entire module -tc_rn_src_decls ds - = do { let { (first_group, group_tail) = findSplice ds } ; - -- If ds is [] we get ([], Nothing) +Here is the grand plan, implemented in tcUserStmt - -- Type check the decls up to, but not including, the first splice - tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ; + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] - -- 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 ; + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] - setEnvs tc_envs $ + expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] + [NB: result not printed] bindings: [it] + + expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] + result showable) bindings: [it] - -- If there is no splice, we're nearly done - case group_tail of { - Nothing -> do { -- Last thing: check for `main' - tcg_env <- checkMain ; - return (tcg_env, tcl_env) - } ; + expr (of non-IO type, + result not showable) ==> error - -- If there's a splice, we must carry on - Just (SpliceDecl splice_expr, rest_ds) -> do { -#ifndef GHCI - failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") -#else - -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ; - failIfErrsM ; -- Don't typecheck if renaming failed +\begin{code} +--------------------------- +tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id) +tcUserStmt (L _ (ExprStmt expr _)) + = newUnique `thenM` \ uniq -> + let + fresh_it = itName uniq + the_bind = noLoc $ FunBind (noLoc fresh_it) False + [ mkSimpleMatch [] expr placeHolderType ] + in + tryTcLIE_ (do { -- Try this if the other fails + traceTc (text "tcs 1b") ; + tc_stmts [ + nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive], + nlExprStmt (nlHsApp (nlHsVar printName) + (nlHsVar fresh_it)) + ] }) + (do { -- Try this first + traceTc (text "tcs 1a") ; + tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] }) - -- Execute the splice - spliced_decls <- tcSpliceDecls rn_splice_expr ; +tcUserStmt stmt = tc_stmts [stmt] - -- Glue them on the front of the remaining decls and loop - setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - tc_rn_src_decls (spliced_decls ++ rest_ds) -#endif /* GHCI */ - }}} -\end{code} +--------------------------- +tc_stmts stmts + = do { ioTyCon <- tcLookupTyCon ioTyConName ; + let { + ret_ty = mkListTy unitTy ; + io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; + names = map unLoc (collectStmtsBinders stmts) ; -%************************************************************************ -%* * - Type-checking the top level of a module -%* * -%************************************************************************ + stmt_ctxt = SC { sc_what = DoExpr, + sc_rhs = check_rhs, + sc_body = check_body, + sc_ty = ret_ty } ; -tcRnGroup takes a bunch of top-level source-code declarations, and - * renames them - * gets supporting declarations from interface files - * typechecks them - * zonks them - * and augments the TcGblEnv with the results + check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ; + check_body body = tcCheckRho body io_ret_ty ; -In Template Haskell it may be called repeatedly for each group of -declarations. It expects there to be an incoming TcGblEnv in the -monad; it augments it and returns the new TcGblEnv. + -- mk_return builds the expression + -- returnIO @ [()] [coerce () x, .., coerce () z] + -- + -- Despite the inconvenience of building the type applications etc, + -- this *has* to be done in type-annotated post-typecheck form + -- because we are going to return a list of *polymorphic* values + -- coerced to type (). If we built a *source* stmt + -- return [coerce x, ..., coerce z] + -- then the type checker would instantiate x..z, and we wouldn't + -- get their *polymorphic* values. (And we'd get ambiguity errs + -- if they were overloaded, since they aren't applied to anything.) + mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty]) + (noLoc $ ExplicitList unitTy (map mk_item ids)) ; + mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy]) + (nlHsVar id) ; -\begin{code} -tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) - -- Returns the variables free in the decls, for unused-binding reporting -tcRnGroup decls - = do { -- Rename the declarations - (tcg_env, rn_decls) <- rnTopSrcDecls decls ; - setGblEnv tcg_env $ do { + io_ty = mkTyConApp ioTyCon [] + } ; - -- Typecheck the declarations - tcTopSrcDecls rn_decls - }} + -- OK, we're ready to typecheck the stmts + traceTc (text "tcs 2") ; + ((ids, tc_expr), lie) <- getLIE $ do { + (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $ + do { + -- Look up the names right in the middle, + -- where they will all be in scope + ids <- mappM tcLookupId names ; + ret_id <- tcLookupId returnIOName ; -- return @ IO + return (ids, [nlResultStmt (mk_return ret_id ids)]) } ; ------------------------------------------------- -rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) -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 { + io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ; + return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty)) + } ; - traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ; - failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations + -- Simplify the context right here, so that we fail + -- if there aren't enough instances. Notably, when we see + -- 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") ; + const_binds <- tcSimplifyInteractive lie ; - -- Rename the source decls - (tcg_env, rn_decls) <- rnSrcDecls group ; - failIfErrsM ; + -- Build result expression and zonk it + let { expr = mkHsLet const_binds tc_expr } ; + zonked_expr <- zonkTopLExpr expr ; + zonked_ids <- zonkTopBndrs ids ; - -- Dump trace of renaming part - rnDump (ppr rn_decls) ; + -- 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) ; - return (tcg_env, rn_decls) - }} + return (zonked_ids, zonked_expr) + } + where + combine stmt (ids, stmts) = (ids, stmt:stmts) + bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), + nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) +\end{code} ------------------------------------------------- -tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls - (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 <- checkNoErrs (tcTyAndClassDecls tycl_decls) ; - -- tcTyAndClassDecls recovers internally, but if anything gave rise to - -- an error we'd better stop now, to avoid a cascade - - -- 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) ; +tcRnExpr just finds the type of an expression +\begin{code} +tcRnExpr :: HscEnv + -> InteractiveContext + -> LHsExpr RdrName + -> IO (Maybe Type) +tcRnExpr hsc_env ictxt rdr_expr + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext ictxt $ do { - setGblEnv tcg_env $ do { - -- Source-language instances, including derivings, - -- and import the supporting declarations - traceTc (text "Tc3") ; - (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ; - setGblEnv tcg_env $ do { + (rn_expr, fvs) <- rnLExpr rdr_expr ; + failIfErrsM ; - -- 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 foreign_decls ; - tcExtendGlobalValEnv fi_ids $ do { + -- Now typecheck the expression; + -- it might have a rank-2 type (e.g. :t runST) + ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; + ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; + tcSimplifyInteractive lie_top ; - -- Default declarations - traceTc (text "Tc4a") ; - default_tys <- tcDefaults default_decls ; - updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { - - -- Value declarations next - -- We also typecheck any extra binds that came out - -- of the "deriving" process (deriv_binds) - traceTc (text "Tc5") ; - (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ; - setLclTypeEnv lcl_env $ do { + let { all_expr_ty = mkForAllTys qtvs $ + mkFunTys (map idType dict_ids) $ + res_ty } ; + zonkTcType all_expr_ty + } + where + smpl_doc = ptext SLIT("main expression") +\end{code} - -- Second pass over class and instance declarations, - traceTc (text "Tc6") ; - (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ; - showLIE (text "after instDecls2") ; +tcRnExpr just finds the kind of a type - -- Foreign exports - -- They need to be zonked, so we return them - traceTc (text "Tc7") ; - (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; +\begin{code} +tcRnType :: HscEnv + -> InteractiveContext + -> LHsType RdrName + -> IO (Maybe Kind) +tcRnType hsc_env ictxt rdr_type + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext ictxt $ do { - -- Rules - rules <- tcRules rule_decls ; + rn_type <- rnLHsType doc rdr_type ; + failIfErrsM ; - -- Wrap up - traceTc (text "Tc7a") ; - tcg_env <- getGblEnv ; - let { all_binds = tc_val_binds `unionBags` - inst_binds `unionBags` - foe_binds ; + -- Now kind-check the type + (ty', kind) <- kcHsType rn_type ; + return kind + } + where + doc = ptext SLIT("In GHCi input") - -- Extend the GblEnv with the (as yet un-zonked) - -- bindings, rules, foreign decls - tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds, - tcg_rules = tcg_rules tcg_env ++ rules, - tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; - return (tcg_env', lcl_env) - }}}}}} +#endif /* GHCi */ \end{code} -%********************************************************* -%* * - mkGlobalContext: make up an interactive context - - Used for initialising the lexical environment - of the interactive read-eval-print loop -%* * -%********************************************************* +%************************************************************************ +%* * + More GHCi stuff, to do with browsing and getting info +%* * +%************************************************************************ \begin{code} #ifdef GHCI mkExportEnv :: HscEnv -> [ModuleName] -- Expose these modules' exports only -> IO GlobalRdrEnv - mkExportEnv hsc_env exports = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $ mappM getModuleExports exports @@ -897,7 +906,7 @@ getModuleContents hsc_env ictxt mod exports_only -- so it had better be a home module = do { hpt <- getHpt ; case lookupModuleEnvByName hpt mod of - Just mod_info -> return (map (toIfaceDecl ictxt) $ + Just mod_info -> return (map toIfaceDecl $ filter wantToSee $ typeEnvElts $ md_types (hm_details mod_info)) @@ -913,7 +922,7 @@ getModuleContents hsc_env ictxt mod exports_only get_decl avail = do { thing <- tcLookupGlobal (availName avail) - ; return (filter_decl (availOccs avail) (toIfaceDecl ictxt thing)) } + ; return (filter_decl (availOccs avail) (toIfaceDecl thing)) } --------------------- filter_decl occs decl@(IfaceClass {ifSigs = sigs}) @@ -943,83 +952,109 @@ load_iface mod = loadSrcInterface doc mod False {- Not boot iface -} --------------------- noRdrEnvErr mod = ptext SLIT("No top-level environment available for module") <+> quotes (ppr mod) -#endif \end{code} -%************************************************************************ -%* * - Checking for 'main' -%* * -%************************************************************************ - \begin{code} -checkMain - = do { ghci_mode <- getGhciMode ; - tcg_env <- getGblEnv ; +tcRnGetInfo :: HscEnv + -> InteractiveContext + -> RdrName + -> IO (Maybe [(IfaceDecl, + Fixity, SrcLoc, + [(IfaceInst, SrcLoc)])]) +-- Used to implemnent :info in GHCi +-- +-- Look up a RdrName and return all the TyThings it might be +-- A capitalised RdrName is given to us in the DataName namespace, +-- but we want to treat it as *both* a data constructor +-- *and* as a type or class constructor; +-- hence the call to dataTcOccs, and we return up to two results +tcRnGetInfo hsc_env ictxt rdr_name + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext ictxt $ do { - mb_main_mod <- readMutVar v_MainModIs ; - mb_main_fn <- readMutVar v_MainFunIs ; - let { main_mod = case mb_main_mod of { - Just mod -> mkModuleName mod ; - Nothing -> mAIN_Name } ; - main_fn = case mb_main_fn of { - Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ; - Nothing -> main_RDR_Unqual } } ; - - check_main ghci_mode tcg_env main_mod main_fn - } + -- If the identifier is a constructor (begins with an + -- upper-case letter), then we need to consider both + -- constructor and type class identifiers. + let { rdr_names = dataTcOccs rdr_name } ; + -- results :: [(Messages, Maybe Name)] + results <- mapM (tryTc . lookupOccRn) rdr_names ; -check_main ghci_mode tcg_env main_mod main_fn - -- If we are in module Main, check that 'main' is defined. - -- It may be imported from another module! - -- - -- ToDo: We have to return the main_name separately, because it's a - -- bona fide 'use', and should be recorded as such, but the others - -- aren't - -- - -- Blimey: a whole page of code to do this... - | mod_name /= main_mod - = return tcg_env + traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]); + -- The successful lookups will be (Just name) + let { (warns_s, good_names) = unzip [ (msgs, name) + | (msgs, Just name) <- results] ; + errs_s = [msgs | (msgs, Nothing) <- results] } ; - | otherwise - = addErrCtxt mainCtxt $ - do { mb_main <- lookupSrcOcc_maybe main_fn - -- Check that 'main' is in scope - -- It might be imported from another module! - ; case mb_main of { - Nothing -> do { complain_no_main - ; return tcg_env } ; - Just main_name -> do - { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) } - -- :Main.main :: IO () = runIO main + -- Fail if nothing good happened, else add warnings + if null good_names then + -- No lookup succeeded, so + -- pick the first error message and report it + -- ToDo: If one of the errors is "could be Foo.X or Baz.X", + -- while the other is "X is not in scope", + -- we definitely want the former; but we might pick the latter + do { addMessages (head errs_s) ; failM } + else -- Add deprecation warnings + mapM_ addMessages warns_s ; + + -- And lookup up the entities, avoiding duplicates, which arise + -- because constructors and record selectors are represented by + -- their parent declaration + let { do_one name = do { thing <- tcLookupGlobal name + ; let decl = toIfaceDecl thing + ; fixity <- lookupFixityRn name + ; insts <- lookupInsts thing + ; return (decl, fixity, getSrcLoc thing, + map mk_inst insts) } ; + -- For the SrcLoc, the 'thing' has better info than + -- the 'name' because getting the former forced the + -- declaration to be loaded into the cache + mk_inst dfun = (dfunToIfaceInst dfun, getSrcLoc dfun) ; + cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2 } ; + results <- mapM do_one good_names ; + return (fst (removeDups cmp results)) + } - ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $ - tcInferRho rhs +lookupInsts :: TyThing -> TcM [DFunId] +lookupInsts (AClass cls) + = do { loadImportedInsts cls [] -- [] means load all instances for cls + ; inst_envs <- tcGetInstEnvs + ; return [df | (_,_,df) <- classInstances inst_envs cls] } + +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 + ; mapM_ (\c -> loadImportedInsts c []) + (typeEnvClasses (eps_PTE eps)) + ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all + ; return (get home_ie ++ get pkg_ie) } + where + get ie = [df | (_,_,df) <- instEnvElts ie, relevant df] + relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) + tc_name = tyConName tc - ; let { root_main_id = mkExportedLocalId rootMainName ty ; - main_bind = noLoc (VarBind root_main_id main_expr) } +lookupInsts other = return [] - ; return (tcg_env { tcg_binds = tcg_binds tcg_env - `snocBag` main_bind, - tcg_dus = tcg_dus tcg_env - `plusDU` usesOnly (unitFV main_name) - }) - }}} + +toIfaceDecl :: TyThing -> IfaceDecl +toIfaceDecl thing + = tyThingToIfaceDecl True -- Discard IdInfo + emptyNameSet -- Show data cons + ext_nm (munge thing) where - mod_name = moduleName (tcg_mod tcg_env) - - complain_no_main | ghci_mode == Interactive = 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. + ext_nm n = ExtPkg (nameModuleName n) (nameOccName n) - 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) - <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) -\end{code} + -- munge transforms a thing to it's "parent" thing + munge (ADataCon dc) = ATyCon (dataConTyCon dc) + munge (AnId id) = case globalIdDetails id of + RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl) + ClassOpId cls -> AClass cls + other -> AnId id + munge other_thing = other_thing +#endif /* GHCI */ +\end{code} %************************************************************************ %* *