Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/542dd73658709e8fde109b459427db84c34d5aaf >--------------------------------------------------------------- commit 542dd73658709e8fde109b459427db84c34d5aaf Author: Simon Peyton Jones <[email protected]> Date: Mon Feb 6 08:42:38 2012 +0000 Refactor tcUserStmt, to fix Trac #5829 The problem was that the FunBind we we build in the expression case didn't have the right free variables, and that tripped an ASSERT later. >--------------------------------------------------------------- compiler/main/HscTypes.lhs | 8 ++- compiler/typecheck/TcRnDriver.lhs | 75 ++++++++++++++++++++----------------- 2 files changed, 46 insertions(+), 37 deletions(-) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 3224acf..9840b40 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -931,7 +931,8 @@ data InteractiveContext ic_tythings :: [TyThing], -- ^ TyThings defined by the user, in reverse order of - -- definition. + -- definition. At a breakpoint, this list includes the + -- local variables in scope at that point ic_sys_vars :: [Id], -- ^ Variables defined automatically by the system (e.g. @@ -1386,8 +1387,9 @@ lookupType dflags hpt pte name lookupNameEnv (md_types (hm_details hm)) name | otherwise = lookupNameEnv pte name - where mod = ASSERT( isExternalName name ) nameModule name - this_pkg = thisPackage dflags + where + mod = ASSERT2( isExternalName name, ppr name ) nameModule name + this_pkg = thisPackage dflags -- | As 'lookupType', but with a marginally easier-to-use interface -- if you have a 'HscEnv' diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 3974e65..6debc42 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -549,7 +549,7 @@ tcRnHsBootDecls decls ; mapM_ (badBootDecl "vect") vect_decls -- Typecheck type/class decls - ; traceTc "Tc2" empty + ; traceTc "Tc2 (boot)" empty ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls ; setGblEnv tcg_env $ do { @@ -892,7 +892,7 @@ tcTopSrcDecls boot_details hs_valds = val_binds }) = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls - traceTc "Tc2" empty ; + traceTc "Tc2 (src)" empty ; tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; setGblEnv tcg_env $ do { @@ -1171,15 +1171,8 @@ tcRnStmt hsc_env ictxt rdr_stmt = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { - -- Rename; use CmdLineMode because tcRnStmt is only used interactively - (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ -> - return ((), emptyFVs) ; - traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; - failIfErrsM ; - rnDump (ppr rn_stmt) ; - -- The real work is done here - (bound_ids, tc_expr) <- tcUserStmt rn_stmt ; + (bound_ids, tc_expr) <- tcUserStmt rdr_stmt ; zonked_expr <- zonkTopLExpr tc_expr ; zonked_ids <- zonkTopBndrs bound_ids ; @@ -1283,20 +1276,27 @@ runPlans (p:ps) = tryTcLIE_ (runPlans ps) p -- for more details. We do this lifting by trying different ways ('plans') of -- lifting the code into the IO monad and type checking each plan until one -- succeeds. -tcUserStmt :: LStmt Name -> TcM PlanResult +tcUserStmt :: LStmt RdrName -> TcM PlanResult -- An expression typed at the prompt is treated very specially tcUserStmt (L loc (ExprStmt expr _ _ _)) - = do { uniq <- newUnique + = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) + -- Don't try to typecheck if the renamer fails! + ; uniq <- newUnique ; let fresh_it = itName uniq loc - matches = [mkMatch [] expr emptyLocalBinds] + matches = [mkMatch [] rn_expr emptyLocalBinds] -- [it = expr] - the_bind = L loc $ mkTopFunBind (L loc fresh_it) matches + the_bind = L loc $ (mkTopFunBind (L loc fresh_it) matches) { bind_fvs = fvs } + -- Care here! In GHCi the expression might have + -- free variables, and they in turn may have free type variables + -- (if we are at a breakpoint, say). We must put those free vars + + -- [let it = expr] let_stmt = L loc $ LetStmt $ HsValBinds $ ValBindsOut [(NonRecursive,unitBag the_bind)] [] -- [it <- e] - bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) expr + bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) rn_expr (HsVar bindIOName) noSyntaxExpr -- [; print it] print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) @@ -1325,27 +1325,34 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) ; tcGhciStmts [let_stmt, print_it] } ]} -tcUserStmt stmt@(L loc (BindStmt {})) - | [v] <- collectLStmtBinders stmt -- One binder, for a bind stmt - = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) - (HsVar thenIOName) noSyntaxExpr placeHolderType - - ; print_bind_result <- doptM Opt_PrintBindResult - ; let print_plan = do - { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] - ; v_ty <- zonkTcType (idType v_id) - ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM - ; return stuff } +tcUserStmt rdr_stmt@(L loc _) + = do { (([rn_stmt], _), fvs) <- checkNoErrs $ + rnStmts GhciStmt [rdr_stmt] $ \_ -> + return ((), emptyFVs) ; + -- Don't try to typecheck if the renamer fails! + ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) + ; rnDump (ppr rn_stmt) ; + + ; opt_pr_flag <- doptM Opt_PrintBindResult + ; let print_result_plan + | opt_pr_flag -- The flag says "print result" + , [v] <- collectLStmtBinders rn_stmt -- One binder + = [mk_print_result_plan rn_stmt v] + | otherwise = [] -- The plans are: - -- [stmt; print v] but not if v::() - -- [stmt] - ; runPlans ((if print_bind_result then [print_plan] else []) ++ - [tcGhciStmts [stmt]]) - } - -tcUserStmt stmt - = tcGhciStmts [stmt] + -- [stmt; print v] if one binder and not v::() + -- [stmt] otherwise + ; runPlans (print_result_plan ++ [tcGhciStmts [rn_stmt]]) } + where + mk_print_result_plan rn_stmt v + = do { stuff@([v_id], _) <- tcGhciStmts [rn_stmt, print_v] + ; v_ty <- zonkTcType (idType v_id) + ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; return stuff } + where + print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) + (HsVar thenIOName) noSyntaxExpr placeHolderType -- | Typecheck the statements given and then return the results of the -- statement in the form 'IO [()]'. _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
