From: simonpj@microsoft.com Date: Wed, 20 Jan 2010 09:45:33 +0000 (+0000) Subject: Fix Trac #3813: unused variables in GHCi bindings X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=85f969a6585c06168645114d9524e7169dbc6e32;ds=sidebyside Fix Trac #3813: unused variables in GHCi bindings In a GHCi stmt we don't want to report unused variables, because we don't know the scope of the binding, eg Prelude> x <- blah Fixing this needed a little more info about the context of the stmt, thus the new constructor GhciStmt in the HsStmtContext type. --- diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index a58e9b4..ef69b47 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -323,6 +323,9 @@ dsExpr (HsDo ListComp stmts body result_ty) dsExpr (HsDo DoExpr stmts body result_ty) = dsDo stmts body result_ty +dsExpr (HsDo GhciStmt stmts body result_ty) + = dsDo stmts body result_ty + dsExpr (HsDo (MDoExpr tbl) stmts body result_ty) = dsMDo tbl stmts body result_ty diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index e95df4d..902eeb8 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -714,20 +714,26 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 ; wrapGenSyns ss z } + -- FIXME: I haven't got the types here right yet -repE (HsDo DoExpr sts body _) +repE e@(HsDo ctxt sts body _) + | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; body' <- addBinds ss $ repLE body; ret <- repNoBindSt body'; - e <- repDoE (nonEmptyCoreList (zs ++ [ret])); - wrapGenSyns ss e } -repE (HsDo ListComp sts body _) + e' <- repDoE (nonEmptyCoreList (zs ++ [ret])); + wrapGenSyns ss e' } + + | ListComp <- ctxt = do { (ss,zs) <- repLSts sts; body' <- addBinds ss $ repLE body; ret <- repNoBindSt body'; - e <- repComp (nonEmptyCoreList (zs ++ [ret])); - wrapGenSyns ss e } -repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e) + e' <- repComp (nonEmptyCoreList (zs ++ [ret])); + wrapGenSyns ss e' } + + | otherwise + = notHandled "mdo and [: :]" (ppr e) + repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitTuple es boxed) diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index f638f65..10c106d 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -978,7 +978,7 @@ pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body pprDo ListComp stmts body = pprComp brackets stmts body pprDo PArrComp stmts body = pprComp pa_brackets stmts body -pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt +pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt, GhciStmt ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc -- Print a bunch of do stmts, with explicit braces and semicolons, @@ -1092,6 +1092,7 @@ data HsMatchContext id -- Context of a Match data HsStmtContext id = ListComp | DoExpr + | GhciStmt -- A command-line Stmt in GHCi pat <- rhs | MDoExpr PostTcTable -- Recursive do-expression -- (tiresomely, it needs table -- of its return/bind ops) @@ -1143,6 +1144,7 @@ pprStmtContext (TransformStmtCtxt c) = sep [ptext (sLit "a transformed branch of"), pprStmtContext c] pprStmtContext (PatGuard ctxt) = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt +pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command") pprStmtContext DoExpr = ptext (sLit "a 'do' expression") pprStmtContext (MDoExpr _) = ptext (sLit "an 'mdo' expression") pprStmtContext ListComp = ptext (sLit "a list comprehension") @@ -1174,6 +1176,7 @@ matchContextErrString ProcExpr = ptext (sLit "proc") matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") +matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression") matchContextErrString (StmtCtxt (MDoExpr _)) = ptext (sLit "'mdo' expression") matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 2f5743a..c6d5052 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -651,7 +651,6 @@ type MiniFixityEnv = FastStringEnv (Located Fixity) -------------------------------- -- Used for nested fixity decls to bind names along with their fixities. -- the fixities are given as a UFM from an OccName's FastString to a fixity decl --- Also check for unused binders bindLocalNamesFV_WithFixities :: [Name] -> MiniFixityEnv -> RnM (a, FreeVars) -> RnM (a, FreeVars) diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 6367255..c06aa38 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -133,9 +133,11 @@ which is how you go from a RdrName to a Name data NameMaker = LamMk -- Lambdas Bool -- True <=> report unused bindings + -- (even if True, the warning only comes out + -- if -fwarn-unused-matches is on) | LetMk -- Let bindings, incl top level - -- Do not check for unused bindings + -- Do *not* check for unused bindings (Maybe Module) -- Just m => top level of module m -- Nothing => not top level MiniFixityEnv @@ -146,8 +148,14 @@ topRecNameMaker mod fix_env = LetMk (Just mod) fix_env localRecNameMaker :: MiniFixityEnv -> NameMaker localRecNameMaker fix_env = LetMk Nothing fix_env -matchNameMaker :: NameMaker -matchNameMaker = LamMk True +matchNameMaker :: HsMatchContext a -> NameMaker +matchNameMaker ctxt = LamMk report_unused + where + -- Do not report unused names in interactive contexts + -- i.e. when you type 'x <- e' at the GHCi prompt + report_unused = case ctxt of + StmtCtxt GhciStmt -> False + _ -> True newName :: NameMaker -> Located RdrName -> CpsRn Name newName (LamMk report_unused) rdr_name @@ -212,8 +220,8 @@ rnPats ctxt pats thing_inside -- (0) bring into scope all of the type variables bound by the patterns -- (1) rename the patterns, bringing into scope all of the term variables -- (2) then do the thing inside. - ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ - unCpsRn (rnLPatsAndThen matchNameMaker pats) $ \ pats' -> do + ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ + unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do { -- Check for duplicated and shadowed names -- Because we don't bind the vars all at once, we can't -- check incrementally for duplicates; diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 3457f32..6d917d1 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -243,8 +243,7 @@ tcDoStmts PArrComp stmts body res_ty (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) } tcDoStmts DoExpr stmts body res_ty - = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts - res_ty $ + = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $ tcBody body ; return (HsDo DoExpr stmts' body' res_ty) } diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 8eb674d..f8c6c4c 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1065,7 +1065,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] (return ((), emptyFVs)) ; + (([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) ; @@ -1234,7 +1234,7 @@ tcGhciStmts stmts let { ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts io_ret_ty ; + tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ; names = map unLoc (collectLStmtsBinders stmts) ; @@ -1269,7 +1269,7 @@ tcGhciStmts stmts traceTc (text "TcRnDriver.tcGhciStmts: done") ; return (ids, mkHsDictLet const_binds $ - noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty)) + noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty)) } \end{code}