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 (file)
--- 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 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
 
 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 (file)
--- 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 }
                               ; e2 <- addBinds ss (repLE e)
                               ; z <- repLetE ds e2
                               ; wrapGenSyns ss z }

+

 -- FIXME: I haven't got the types here right yet
 -- 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';   
  = 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';   
  = 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) 
 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 (file)
--- 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 (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,
 
 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
 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)
   | 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
  = 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")
 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 (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")
 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 (file)
--- 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
 --------------------------------
 -- 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)
 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 (file)
--- 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
 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
 
   | 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
       (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 
 
 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
 
 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.
          -- (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; 
         { -- 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 (file)
--- 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
                      (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) }
 
                             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 (file)
--- 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
     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) ;
     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] ;
        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) ;
 
 
            names = map unLoc (collectLStmtsBinders stmts) ;
 

@@ -1269,7 +1269,7 @@ tcGhciStmts stmts
 
        traceTc (text "TcRnDriver.tcGhciStmts: done") ;
        return (ids, mkHsDictLet const_binds $
 
        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}
 
     }
 \end{code}