-%*********************************************************
-%* *
-\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
- -> ModIface -- Get the decls from here
- -> IO ModDetails
-tcRnIface hsc_env iface
- = initIfaceIO hsc_env (typecheckIface iface)
-\end{code}
-
-
-%************************************************************************
-%* *
- The interactive interface
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef GHCI
-tcRnStmt :: HscEnv
- -> InteractiveContext
- -> RdrNameStmt
- -> IO (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 ictxt rdr_stmt
- = initTc 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 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 <- [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 >>= \ 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 ;
- io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
-
- 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 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 = HsApp (TyApp (HsVar ret_id) [ret_ty])
- (ExplicitList unitTy (map mk_item ids)) ;
- mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
- (HsVar id) ;
-
- io_ty = mkTyConApp ioTyCon []
- } ;
-
- -- 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, [ResultStmt (mk_return ret_id ids) interactiveSrcLoc]) } ;
-
- io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
- return (ids, HsDo DoExpr tc_stmts io_ids io_ret_ty interactiveSrcLoc)
- } ;
-
- -- 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 ;
-
- -- Build result expression and zonk it
- let { expr = mkHsLet const_binds tc_expr } ;
- zonked_expr <- zonkTopExpr expr ;
- zonked_ids <- zonkTopBndrs ids ;
-
- return (zonked_ids, zonked_expr)
- }
- where
- combine stmt (ids, stmts) = (ids, stmt:stmts)
-\end{code}
-
-
-tcRnExpr just finds the type of an expression
-
-\begin{code}
-tcRnExpr :: HscEnv
- -> InteractiveContext
- -> RdrNameHsExpr
- -> IO (Maybe Type)
-tcRnExpr hsc_env ictxt rdr_expr
- = initTc hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
-
- (rn_expr, fvs) <- rnExpr rdr_expr ;
- failIfErrsM ;
-
- -- 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 ;
-
- 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}
-
-
-\begin{code}
-tcRnThing :: HscEnv
- -> InteractiveContext
- -> RdrName
- -> IO (Maybe [(IfaceDecl, Fixity)])
--- 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
- = initTc hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
-
- -- 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 ;
-
- -- 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] } ;
-
- -- 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
- mapM do_one good_names
- }
- where
- do_one name = do { thing <- tcLookupGlobal name
- ; fixity <- lookupFixityRn name
- ; return (toIfaceDecl ictxt thing, fixity) }
-
-toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl
-toIfaceDecl ictxt thing
- = tyThingToIfaceDecl True {- Discard IdInfo -} ext_nm thing
- where
- unqual = icPrintUnqual ictxt
- ext_nm n | unqual n = LocalTop (nameOccName n) -- What a hack
- | otherwise = ExtPkg (nameModuleName n) (nameOccName n)
-\end{code}
-
-
-\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 */
-\end{code}
-