- -- For OneShot compilation we could just throw away the decls
- -- but for Batch or Interactive we must put them in the type
- -- envt because they've been removed from the holding pen
- let { export_fvs = availsToNameSet export_avails } ;
- tcg_env <- importSupportingDecls export_fvs ;
- setGblEnv tcg_env $ do {
-
- -- Report unused names
- let { all_dus = src_dus `plusDU` usesOnly export_fvs } ;
- reportUnusedNames tcg_env all_dus ;
-
- -- Dump output and return
- tcDump tcg_env ;
- return tcg_env
- }}}}}}}
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Closing up the interface decls}
-%* *
-%*********************************************************
-
-Suppose we discover we don't need to recompile. Then we start from the
-IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
-
-\begin{code}
-tcRnIface :: HscEnv
- -> PersistentCompilerState
- -> ModIface -- Get the decls from here
- -> IO (PersistentCompilerState, Maybe ModDetails)
- -- Nothing <=> errors happened
-tcRnIface hsc_env pcs
- (ModIface {mi_module = mod, mi_decls = iface_decls})
- = initTc hsc_env pcs mod $ do {
-
- -- Get the supporting decls, and typecheck them all together
- -- so that any mutually recursive types are done right
- extra_decls <- slurpImpDecls needed ;
- env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ;
-
- returnM (ModDetails { md_types = tcg_type_env env,
- md_insts = tcg_insts env,
- md_rules = hsCoreRules (tcg_rules env)
- -- All the rules from an interface are of the IfaceRuleOut form
- }) }
- where
- rule_decls = dcl_rules iface_decls
- inst_decls = dcl_insts iface_decls
- tycl_decls = dcl_tycl iface_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`
- ubiquitousNames
- -- Data type decls with record selectors,
- -- which may appear in the decls, need unpackCString
- -- and friends. It's easier to just grab them right now.
-
-hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule]
--- All post-typechecking Iface rules have the form IfaceRuleOut
-hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules]
-\end{code}
-
-
-%************************************************************************
-%* *
- The interactive interface
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef GHCI
-tcRnStmt :: HscEnv -> PersistentCompilerState
- -> InteractiveContext
- -> RdrNameStmt
- -> IO (PersistentCompilerState,
- Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
- -- 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
- ([rn_stmt], fvs) <- initRnInteractive ictxt
- (rnStmts DoExpr [rdr_stmt]) ;
- traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
- failIfErrsM ;
-
- -- Suck in the supporting declarations and typecheck them
- tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ;
- -- NB: an earlier version deleted (rdrEnvElts local_env) from
- -- the fvs. But (a) that isn't necessary, because previously
- -- bound things in the local_env will be in the TypeEnv, and
- -- the renamer doesn't re-slurp such things, and
- -- (b) it's WRONG to delete them. Consider in GHCi:
- -- Mod> let x = e :: T
- -- Mod> let y = x + 3
- -- We need to pass 'x' among the fvs to slurpImpDecls, so that
- -- the latter can see that T is a gate, and hence import the Num T
- -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.)
- setGblEnv tcg_env $ do {
-
- -- The real work is done here
- ((bound_ids, tc_expr), lie) <- getLIE (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 bound_ids ;
- globaliseId id = setGlobalIdDetails id VanillaGlobal ;
-
- -- 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 <- [lookupRdrEnv 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 >>= \ v -> return [coerce HVal v]
- [NB: result not printed] bindings: [it]
-
- expr (of non-IO type, ==> let v = expr in print v >> return [coerce HVal v]
- result showable) bindings: [it]
-
- expr (of non-IO type,
- result not showable) ==> error
-
-
-\begin{code}
----------------------------
-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
- tryTcLIE_ (do { -- Try this if the other fails
- traceTc (text "tcs 1b") ;
- 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 [BindStmt (VarPat fresh_it) expr loc] })
-
-tcUserStmt stmt = tc_stmts [stmt]
-
----------------------------
-tc_stmts stmts
- = do { ioTyCon <- tcLookupTyCon ioTyConName ;
- let {
- ret_ty = mkListTy unitTy ;
- names = 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 (mkTyConApp ioTyCon [ret_ty]) ;
-
- -- ret_expr is the expression
- -- returnIO [coerce () x, .., coerce () z]
- ret_stmt = ResultStmt ret_expr noSrcLoc ;
- ret_expr = HsApp (HsVar returnIOName)
- (ExplicitList placeHolderType (map mk_item names)) ;
- mk_item name = HsApp (HsVar unsafeCoerceName) (HsVar name) ;
-
- all_stmts = stmts ++ [ret_stmt]
- } ;
-
- -- OK, we're ready to typecheck the stmts
- traceTc (text "tcs 2") ;
- ((ids, tc_stmts), lie) <-
- getLIE $
- 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 ;
- return (ids, [])
- } ;
-
- -- 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 <- tcSimplifyTop lie ;
-
- -- Build result expression and zonk it
- io_ids <- mappM mk_rebound
- [returnIOName, failIOName, bindIOName, thenIOName] ;
- let { expr = mkHsLet const_binds $
- HsDo DoExpr tc_stmts io_ids
- (mkTyConApp ioTyCon [ret_ty]) noSrcLoc } ;
- zonked_expr <- zonkTopExpr expr ;
- zonked_ids <- zonkTopBndrs ids ;
-
- return (zonked_ids, zonked_expr)
- }
- where
- combine stmt (ids, stmts) = (ids, stmt:stmts)
- mk_rebound n = do { id <- tcLookupId n; return (n, HsVar id) }
- -- A bit hackoid
-\end{code}
-
-
-tcRnExpr just finds the type of an expression
-
-\begin{code}
-tcRnExpr :: HscEnv -> PersistentCompilerState
- -> InteractiveContext
- -> RdrNameHsExpr
- -> IO (PersistentCompilerState, Maybe Type)
-tcRnExpr hsc_env pcs ictxt rdr_expr
- = initTc hsc_env pcs iNTERACTIVE $
- setInteractiveContext ictxt $ do {
-
- (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
- failIfErrsM ;
-
- -- Suck in the supporting declarations and typecheck them
- tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
- setGblEnv tcg_env $ 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) ;
- tcSimplifyTop lie_top ;
-
- 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}