Commit f6c31c0f authored by simonpj's avatar simonpj
Browse files

[project @ 2003-07-24 07:38:54 by simonpj]

For GHCi, a recent simplification in TcRnDrive.tc_stmts turned out to
be bogus. Briefly, we were returning *monomorphic* values from a user
stmt (e.g. "let f x y = x>y") when we should wrap the *polymorphic* values.

See the comment with mk_return in tc_stmts.
parent 5b7cf08b
......@@ -33,7 +33,7 @@ import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames,
returnIOName, runIOName,
rootMainName, itName, mAIN_Name, unsafeCoerceName
rootMainName, itName, mAIN_Name
)
import RdrName ( RdrName, getRdrName, mkRdrUnqual,
lookupRdrEnv, elemRdrEnv )
......@@ -52,6 +52,7 @@ import TcType ( Type,
mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
)
import Inst ( showLIE, tcStdSyntaxName )
import MkId ( unsafeCoerceId )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
......@@ -381,8 +382,10 @@ tcUserStmt stmt = tc_stmts [stmt]
tc_stmts stmts
= do { ioTyCon <- tcLookupTyCon ioTyConName ;
let {
ret_ty = mkListTy unitTy ;
names = collectStmtsBinders stmts ;
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
names = collectStmtsBinders stmts ;
stmt_ctxt = SC { sc_what = DoExpr,
sc_rhs = check_rhs,
......@@ -390,16 +393,23 @@ tc_stmts stmts
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) ;
check_body body = tcCheckRho body io_ret_ty ;
all_stmts = stmts ++ [ret_stmt] ;
-- 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 []
} ;
......@@ -407,15 +417,16 @@ tc_stmts stmts
-- 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 all_stmts $
(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 ;
return (ids, []) } ;
ret_id <- tcLookupId returnIOName ; -- return @ IO
return (ids, [ResultStmt (mk_return ret_id ids) noSrcLoc]) } ;
io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
return (ids, HsDo DoExpr tc_stmts io_ids
(mkTyConApp ioTyCon [ret_ty]) noSrcLoc)
return (ids, HsDo DoExpr tc_stmts io_ids io_ret_ty noSrcLoc)
} ;
-- Simplify the context right here, so that we fail
......@@ -479,8 +490,10 @@ tcRnThing :: HscEnv -> PersistentCompilerState
-> RdrName
-> IO (PersistentCompilerState, Maybe [TyThing])
-- Look up a RdrName and return all the TyThings it might be
-- We treat a capitalised RdrName as both a data constructor
-- and as a type or class constructor; hence we return up to two results
-- 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 pcs ictxt rdr_name
= initTc hsc_env pcs iNTERACTIVE $
setInteractiveContext ictxt $ do {
......@@ -500,7 +513,12 @@ tcRnThing hsc_env pcs ictxt rdr_name
errs_s = [msgs | (msgs, Nothing) <- results] } ;
-- Fail if nothing good happened, else add warnings
if null good_names then -- Fail
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 ;
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment