From 5f38e9baa8871d2226d40ec1b46674d69eeb226c Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 4 Apr 2005 16:15:04 +0000 Subject: [PATCH] [project @ 2005-04-04 16:15:04 by simonpj] More stage2 wibbles --- ghc/compiler/rename/RnExpr.lhs | 2 +- ghc/compiler/typecheck/TcMatches.lhs | 8 +++---- ghc/compiler/typecheck/TcRnDriver.lhs | 42 ++++++++++----------------------- 3 files changed, 18 insertions(+), 34 deletions(-) diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 0d17226..a1d21eb 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -11,7 +11,7 @@ free variables. \begin{code} module RnExpr ( - rnMatchGroup, rnMatch, rnGRHSs, rnLExpr, rnExpr, + rnMatchGroup, rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts, checkPrecMatch, checkTH ) where diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index afbf379..5aeb1dd 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -5,10 +5,10 @@ \begin{code} module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, - matchCtxt, - tcDoStmts, tcStmts, tcMDoStmt, tcGuardStmt, tcThingWithSig, - tcMatchPats, - TcMatchCtxt(..) + tcMatchPats, matchCtxt, TcMatchCtxt(..), + tcStmts, tcDoStmts, + tcDoStmt, tcMDoStmt, tcGuardStmt, + tcThingWithSig ) where #include "HsVersions.h" diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index ee2cb50..6e22192 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -80,7 +80,7 @@ import Outputable #ifdef GHCI import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), LStmt, LHsExpr, LHsType, mkMatchGroup, - collectStmtsBinders, mkSimpleMatch, + collectLStmtsBinders, mkSimpleMatch, mkExprStmt, mkBindStmt, nlVarPat ) import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), Provenance(..), ImportSpec(..), @@ -88,11 +88,9 @@ import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), import RnSource ( addTcgDUs ) import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs ) import TcHsType ( kcHsType ) -import TcExpr ( tcCheckRho ) import TcIface ( loadImportedInsts ) import TcMType ( zonkTcType, zonkQuantifiedTyVar ) -import TcUnify ( unifyTyConApp ) -import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) +import TcMatches ( tcStmts, tcDoStmt ) import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isUnLiftedType, tyClsNamesOfDFunHead ) @@ -122,7 +120,7 @@ import Var ( globaliseId ) import Name ( nameOccName ) import OccName ( occNameUserString ) import NameEnv ( delListFromNameEnv ) -import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName ) +import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, returnIOName ) import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses, availNames, availName, ModIface(..), icPrintUnqual, ModDetails(..), Dependencies(..) ) @@ -804,7 +802,7 @@ tcRnStmt hsc_env ictxt rdr_stmt setInteractiveContext hsc_env ictxt $ do { -- Rename; use CmdLineMode because tcRnStmt is only used interactively - ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ; + (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; failIfErrsM ; @@ -882,7 +880,7 @@ Here is the grand plan, implemented in tcUserStmt \begin{code} --------------------------- tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id) -tcUserStmt (L loc (ExprStmt expr _)) +tcUserStmt (L loc (ExprStmt expr _ _)) = newUnique `thenM` \ uniq -> let fresh_it = itName uniq @@ -902,27 +900,14 @@ tcUserStmt (L loc (ExprStmt expr _)) tcUserStmt stmt = tc_stmts [stmt] --------------------------- -tc_stmts :: [Stmt RdrName] -> +tc_stmts :: [LStmt Name] -> TcM ([Id], LHsExpr Id) 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_bind = infer_rhs, - sc_expr = infer_rhs, - sc_body = check_body, - sc_ty = ret_ty } ; - - infer_rhs _bind_op rhs - = do { (rhs', rhs_ty) <- tcInferRho rhs - ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty - ; return (noSyntaxExpr, rhs', pat_ty) } ; - - check_body body = tcCheckRho body io_ret_ty ; + names = map unLoc (collectLStmtsBinders stmts) ; -- mk_return builds the expression -- returnIO @ [()] [coerce () x, .., coerce () z] @@ -946,12 +931,12 @@ tc_stmts stmts -- OK, we're ready to typecheck the stmts traceTc (text "tcs 2") ; ((ids, tc_expr), lie) <- getLIE $ do { - (tc_stmts, ids) <- 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 } ; + (tc_stmts, ids) <- tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) 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, noLoc (HsDo DoExpr tc_stmts (mk_return ret_id ids) io_ret_ty)) @@ -978,7 +963,6 @@ tc_stmts stmts 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} -- 1.7.10.4