+ -- Typecheck the declarations
+ tcTopSrcDecls rn_decls
+ }}
+
+------------------------------------------------
+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 {
+
+ traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
+ failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
+
+ -- Rename the source decls
+ (tcg_env, rn_decls) <- rnSrcDecls group ;
+ failIfErrsM ;
+
+ -- Dump trace of renaming part
+ rnDump (ppr rn_decls) ;
+
+ return (tcg_env, rn_decls)
+ }}
+
+------------------------------------------------
+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) ;
+
+
+ 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 {
+
+ -- 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 {
+
+ -- 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 {
+
+ -- Second pass over class and instance declarations,
+ traceTc (text "Tc6") ;
+ (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
+ showLIE (text "after instDecls2") ;
+
+ -- 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 ;
+
+ -- 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}
+
+
+%************************************************************************
+%* *
+ Checking for 'main'
+%* *
+%************************************************************************
+
+\begin{code}
+checkMain
+ = do { ghci_mode <- getGhciMode ;
+ tcg_env <- getGblEnv ;
+
+ 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
+ }
+
+
+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
+
+ | 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
+
+ ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
+ tcInferRho rhs
+
+ ; let { root_main_id = mkExportedLocalId rootMainName ty ;
+ main_bind = noLoc (VarBind root_main_id main_expr) }
+
+ ; 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.
+
+ 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}
+
+
+%*********************************************************
+%* *
+ GHCi stuff
+%* *
+%*********************************************************
+
+\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}
+
+
+\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 {
+
+ -- 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 ;
+
+ bound_names = map idName global_ids ;
+ new_rn_env = extendLocalRdrEnv rn_env bound_names ;
+
+ -- 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] ] ;
+
+ filtered_type_env = delListFromNameEnv type_env shadowed ;
+ new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
+
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ } ;
+
+ dumpOptTcRn Opt_D_dump_tc
+ (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
+ text "Typechecked expr" <+> ppr tc_expr]) ;
+
+ returnM (new_ic, bound_names, tc_expr)
+ }
+\end{code}
+
+
+Here is the grand plan, implemented in tcUserStmt
+
+ 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,...]
+
+ pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
+ bindings: [x,y,...]
+
+ 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]
+
+ expr (of non-IO type,
+ result not showable) ==> error
+
+
+\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] })
+
+tcUserStmt stmt = tc_stmts [stmt]
+
+---------------------------
+tc_stmts stmts
+ = do { ioTyCon <- tcLookupTyCon ioTyConName ;
+ let {
+ ret_ty = mkListTy unitTy ;
+ io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+
+ names = map unLoc (collectStmtsBinders stmts) ;
+
+ stmt_ctxt = SC { sc_what = DoExpr,
+ sc_rhs = check_rhs,
+ sc_body = check_body,
+ sc_ty = ret_ty } ;
+
+ check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
+ check_body body = tcCheckRho body io_ret_ty ;
+
+ -- 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) ;
+
+ io_ty = mkTyConApp ioTyCon []
+ } ;