Improve free-variable handling for rnPat and friends (fixes Trac #1972)

As well as fixing the immediate problem (Trac #1972) this patch does
a signficant simplification and refactoring of pattern renaming.

Fewer functions, fewer parameters passed....it's all good.  But it
took much longer than I expected to figure out.

The most significant change is that the NameMaker type does *binding*
as well as *making* and, in the matchNameMaker case, checks for unused
bindings as well.  This is much tider.

(No need to merge to the 6.8 branch, but no harm either.)

compiler/rename/RnBinds.lhs

@@ -32,8 +32,8 @@ import RdrHsSyn
 import RnHsSyn
 import TcRnMonad
 import RnTypes        ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch)
-import RnPat          (rnPatsAndThen_LocalRightwards, rnPat_LocalRec, rnPat_TopRec, 
-                       NameMaker, localNameMaker, topNameMaker, applyNameMaker, 
+import RnPat          (rnPatsAndThen_LocalRightwards, rnBindPat,
+                       NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker, 
                        patSigErr)
                       
 import RnEnv		( lookupLocatedBndrRn, 
@@ -179,7 +179,7 @@ rnTopBindsLHS :: UniqFM (Located Fixity) -- mini fixity env for the names we're
               -> HsValBinds RdrName 
               -> RnM (HsValBindsLR Name RdrName)
 rnTopBindsLHS fix_env binds = 
-    (uncurry $ rnValBindsLHSFromDoc True) (bindersAndDoc binds) fix_env binds
+    (uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds
 
 rnTopBindsRHS :: [Name] -- the names bound by these binds
               -> HsValBindsLR Name RdrName 
@@ -282,10 +282,8 @@ rnValBindsLHSFromDoc_Local boundNames doc fix_env binds = do
      -- Do error checking: we need to check for dups here because we
      -- don't don't bind all of the variables from the ValBinds at once
      -- with bindLocatedLocals any more.
-     --
-     checkDupNames doc boundNames
-     -- Warn about shadowing, but only in source modules
-     ifOptM Opt_WarnNameShadowing (checkShadowing doc boundNames)   
+     checkDupNames  doc boundNames
+     checkShadowing doc boundNames   
 
      -- (Note that we don't want to do this at the top level, since
      -- sorting out duplicates and shadowing there happens elsewhere.
@@ -297,7 +295,7 @@ rnValBindsLHSFromDoc_Local boundNames doc fix_env binds = do
      --   import A(f)
      --   g = let f = ... in f
      -- should.
-     rnValBindsLHSFromDoc False boundNames doc fix_env binds 
+     rnValBindsLHSFromDoc (localRecNameMaker fix_env) boundNames doc binds 
 
 bindersAndDoc :: HsValBinds RdrName -> ([Located RdrName], SDoc)
 bindersAndDoc binds = 
@@ -311,17 +309,15 @@ bindersAndDoc binds =
 -- renames the left-hand sides
 -- generic version used both at the top level and for local binds
 -- does some error checking, but not what gets done elsewhere at the top level
-rnValBindsLHSFromDoc :: Bool -- top or not
+rnValBindsLHSFromDoc :: NameMaker 
                      -> [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice)
                      -> SDoc              -- doc string for dup names and shadowing
-                     -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
-                                                -- these fixities need to be brought into scope with the names
                      -> HsValBinds RdrName
                      -> RnM (HsValBindsLR Name RdrName)
-rnValBindsLHSFromDoc topP original_bndrs doc fix_env binds@(ValBindsIn mbinds sigs)
+rnValBindsLHSFromDoc topP original_bndrs doc binds@(ValBindsIn mbinds sigs)
  = do
      -- rename the LHSes
-     mbinds' <- mapBagM (rnBindLHS topP doc fix_env) mbinds
+     mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
      return $ ValBindsIn mbinds' sigs
 
 -- assumes the LHS vars are in scope
@@ -383,7 +379,8 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside =
       let bound_names = map unLoc $ collectHsValBinders new_lhs
 
       --     and bring them (and their fixities) into scope
-      bindLocalNamesFV_WithFixities bound_names new_fixities $ do
+      bindLocalNamesFV_WithFixities bound_names new_fixities $ 
+        warnUnusedLocalBinds bound_names $ do
 
       -- (C) do the RHS and thing inside
       (binds', dus) <- rnValBindsRHS bound_names new_lhs 
@@ -401,13 +398,6 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside =
                 -- bindings in the wrong order, and the type checker will complain
                 -- that x isn't in scope
 
-            -- check for unused binders.  note that we only want to do
-            -- this for local ValBinds; it gets done elsewhere for
-            -- top-level binds (where the scoping is different)
-            unused_bndrs = [ b | b <- bound_names, not (b `elemNameSet` all_uses)]
-
-      warnUnusedLocalBinds unused_bndrs
-
       return (result, 
               -- the bound names are pruned out of all_uses
               -- by the bindLocalNamesFV call above
@@ -456,24 +446,22 @@ dupFixityDecl loc rdr_name
 
 -- renaming a single bind
 
-rnBindLHS :: Bool -- top if true; local if false
+rnBindLHS :: NameMaker
           -> SDoc 
-          -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
-                                     -- these fixities need to be brought into scope with the names
           -> LHsBind RdrName
           -- returns the renamed left-hand side,
           -- and the FreeVars *of the LHS*
           -- (i.e., any free variables of the pattern)
           -> RnM (LHsBindLR Name RdrName)
 
-rnBindLHS topP doc fix_env (L loc (PatBind { pat_lhs = pat, 
+rnBindLHS name_maker doc (L loc (PatBind { pat_lhs = pat, 
                                            pat_rhs = grhss, 
                                            bind_fvs=bind_fvs,
                                            pat_rhs_ty=pat_rhs_ty
                                          })) 
   = setSrcSpan loc $ do
       -- we don't actually use the FV processing of rnPatsAndThen here
-      (pat',pat'_fvs) <- (if topP then rnPat_TopRec else rnPat_LocalRec) fix_env pat
+      (pat',pat'_fvs) <- rnBindPat name_maker pat
       return (L loc (PatBind { pat_lhs = pat', 
                                pat_rhs = grhss, 
                                -- we temporarily store the pat's FVs here;
@@ -484,25 +472,26 @@ rnBindLHS topP doc fix_env (L loc (PatBind { pat_lhs = pat,
                                -- when we rename the RHS
 			       pat_rhs_ty = pat_rhs_ty }))
 
-rnBindLHS topP doc fix_env (L loc (FunBind { fun_id = name@(L nameLoc _), 
+rnBindLHS name_maker doc (L loc (FunBind { fun_id = name@(L nameLoc _), 
                                            fun_infix = inf, 
                                            fun_matches = matches,
                                            fun_co_fn = fun_co_fn, 
                                            bind_fvs = bind_fvs,
                                            fun_tick = fun_tick
                                          }))
-  = setSrcSpan loc $ do
-      newname <- applyNameMaker (if topP then topNameMaker else localNameMaker) name
-      return (L loc (FunBind { fun_id = L nameLoc newname, 
-                               fun_infix = inf, 
-                               fun_matches = matches,
-                               -- we temporatily store the LHS's FVs (empty in this case) here
-                               -- gets updated when doing the RHS below
-                               bind_fvs = emptyFVs,
-                               -- everything else will get ignored in the next pass
-                               fun_co_fn = fun_co_fn, 
-                               fun_tick = fun_tick
-                               }))
+  = setSrcSpan loc $ 
+    do { (newname, _fvs) <- applyNameMaker name_maker name $ \ newname ->
+		 	    return (newname, emptyFVs) 
+       ; return (L loc (FunBind { fun_id = L nameLoc newname, 
+                             	  fun_infix = inf, 
+                             	  fun_matches = matches,
+                             	  -- we temporatily store the LHS's FVs (empty in this case) here
+                             	  -- gets updated when doing the RHS below
+                             	  bind_fvs = emptyFVs,
+                             	  -- everything else will get ignored in the next pass
+                             	  fun_co_fn = fun_co_fn, 
+                             	  fun_tick = fun_tick
+                             	  })) }
 
 -- assumes the left-hands-side vars are in scope
 rnBind :: (Name -> [Name])		-- Signature tyvar function
@@ -789,7 +778,7 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
 
 	-- Now the main event
        -- note that there are no local ficity decls for matches
-    rnPatsAndThen_LocalRightwards ctxt pats	$ \ (pats',_) ->
+    rnPatsAndThen_LocalRightwards ctxt pats	$ \ pats' ->
     rnGRHSs ctxt grhss		`thenM` \ (grhss', grhss_fvs) ->
 
     returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)

compiler/rename/RnEnv.lhs

@@ -74,7 +74,7 @@ import BasicTypes	( IPName, mapIPName, Fixity )
 import SrcLoc		( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc,
 			  srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan )
 import Outputable
-import Util		( sortLe )
+import Util
 import Maybes
 import ListSetOps	( removeDups )
 import List		( nubBy )
@@ -562,17 +562,23 @@ bindLocalFixities fixes thing_inside
 
 -- 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
-bindLocalNamesFV_WithFixities :: [Name] -> UniqFM (Located Fixity) -> RnM (a, FreeVars) -> RnM (a, FreeVars)
-bindLocalNamesFV_WithFixities names fixities cont = 
+-- Also check for unused binders
+bindLocalNamesFV_WithFixities :: [Name]
+			      -> UniqFM (Located Fixity)
+			      -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+bindLocalNamesFV_WithFixities names fixities thing_inside
+  = bindLocalNamesFV names $
+    extendFixityEnv boundFixities $ 
+    thing_inside
+  where
     -- find the names that have fixity decls
-    let boundFixities = foldr 
+    boundFixities = foldr 
                         (\ name -> \ acc -> 
                          -- check whether this name has a fixity decl
                           case lookupUFM fixities (occNameFS (nameOccName name)) of
                                Just (L _ fix) -> (name, FixItem (nameOccName name) fix) : acc
-                               Nothing -> acc) [] names in
+                               Nothing -> acc) [] names
     -- bind the names; extend the fixity env; do the thing inside
-    bindLocalNamesFV names (extendFixityEnv boundFixities cont)
 \end{code}
 
 --------------------------------
@@ -746,9 +752,8 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
   = 	-- Check for duplicate names
     checkDupNames doc_str rdr_names_w_loc	`thenM_`
 
-    	-- Warn about shadowing, but only in source modules
-    ifOptM Opt_WarnNameShadowing 
-      (checkShadowing doc_str rdr_names_w_loc)	`thenM_`
+    	-- Warn about shadowing
+    checkShadowing doc_str rdr_names_w_loc	`thenM_`
 
 	-- Make fresh Names and extend the environment
     newLocalsRn rdr_names_w_loc		`thenM` \ names ->
@@ -847,16 +852,20 @@ checkDupNames doc_str rdr_names_w_loc
 
 -------------------------------------
 checkShadowing doc_str loc_rdr_names
-  = getLocalRdrEnv		`thenM` \ local_env ->
+  = traceRn (text "shadow" <+> ppr loc_rdr_names) `thenM_`
+    getLocalRdrEnv		`thenM` \ local_env ->
     getGlobalRdrEnv		`thenM` \ global_env ->
     let
       check_shadow (L loc rdr_name)
-	|  rdr_name `elemLocalRdrEnv` local_env 
- 	|| not (null (lookupGRE_RdrName rdr_name global_env ))
-	= addWarnAt loc (shadowedNameWarn doc_str rdr_name)
-        | otherwise = returnM ()
+	| Just n <- mb_local = complain [ptext SLIT("bound at") <+> ppr (nameSrcLoc n)]
+	| not (null gres)    = complain (map pprNameProvenance gres)
+	| otherwise	     = return ()
+	where
+	  complain pp_locs = addWarnAt loc (shadowedNameWarn doc_str rdr_name pp_locs)
+	  mb_local = lookupLocalRdrEnv local_env rdr_name
+          gres     = lookupGRE_RdrName rdr_name global_env
     in
-    mappM_ check_shadow loc_rdr_names
+    ifOptM Opt_WarnNameShadowing (mappM_ check_shadow loc_rdr_names)
 \end{code}
 
 
@@ -877,16 +886,13 @@ mapFvRn f xs = mappM f xs	`thenM` \ stuff ->
 -- because some of the rename functions are CPSed:
 -- maps the function across the list from left to right; 
 -- collects all the free vars into one set
-mapFvRnCPS :: (a -> ((b,FreeVars) -> RnM (c, FreeVars)) -> RnM(c, FreeVars)) 
-           -> [a] 
-           -> (([b],FreeVars) -> RnM (c, FreeVars))
-           -> RnM (c, FreeVars)
-
-mapFvRnCPS _ [] cont = cont ([], emptyFVs)
+mapFvRnCPS :: (a  -> (b   -> RnM c) -> RnM c) 
+           -> [a] -> ([b] -> RnM c) -> RnM c
 
-mapFvRnCPS f (h:t) cont = f h $ \ (h',hfv) -> 
-                          mapFvRnCPS f t $ \ (t',tfv) ->
-                              cont (h':t', hfv `plusFV` tfv)
+mapFvRnCPS _ []     cont = cont []
+mapFvRnCPS f (x:xs) cont = f x 		   $ \ x' -> 
+                           mapFvRnCPS f xs $ \ xs' ->
+                           cont (x':xs')
 \end{code}
 
 
@@ -914,9 +920,19 @@ warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
 warnUnusedImports gres  = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres)
 warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds   (warnUnusedGREs gres)
 
-warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM ()
-warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds   (warnUnusedLocals names)
-warnUnusedMatches    names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names)
+warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds
+warnUnusedMatches    = check_unused Opt_WarnUnusedMatches
+
+check_unused :: DynFlag -> [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+check_unused flag names thing_inside
+ =  do	{ (res, res_fvs) <- thing_inside
+	
+	-- Warn about unused names
+	; ifOptM flag (warnUnusedLocals (filterOut (`elemNameSet` res_fvs) names))
+
+	-- And return
+	; return (res, res_fvs) }
 
 -------------------------
 --	Helpers
@@ -967,10 +983,10 @@ addNameClashErrRn rdr_name names
     msgs = [ptext SLIT("    or") <+> mk_ref np | np <- nps]
     mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre
 
-shadowedNameWarn doc shadow
-  = hsep [ptext SLIT("This binding for"), 
-	       quotes (ppr shadow),
-	       ptext SLIT("shadows an existing binding")]
+shadowedNameWarn doc rdr_name shadowed_locs
+  = sep [ptext SLIT("This binding for") <+> quotes (ppr rdr_name)
+	    <+> ptext SLIT("shadows the existing binding") <> plural shadowed_locs,
+	 nest 2 (vcat shadowed_locs)]
     $$ doc
 
 unknownNameErr rdr_name

compiler/rename/RnExpr.lhs

@@ -33,8 +33,8 @@ import HscTypes         ( availNames )
 import RnNames		( getLocalDeclBinders, extendRdrEnvRn )
 import RnTypes		( rnHsTypeFVs, 
 			  mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
-import RnPat          (rnOverLit, rnPatsAndThen_LocalRightwards, rnPat_LocalRec, localNameMaker, 
-                       rnLit,
+import RnPat            (rnOverLit, rnPatsAndThen_LocalRightwards, rnBindPat, 
+                         localRecNameMaker, rnLit,
 			 rnHsRecFields_Con, rnHsRecFields_Update, checkTupSize)
 import DynFlags		( DynFlag(..) )
 import BasicTypes	( FixityDirection(..) )
@@ -289,7 +289,7 @@ rnExpr e@(ELazyPat {}) = patSynErr e
 \begin{code}
 rnExpr (HsProc pat body)
   = newArrowScope $
-    rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ ([pat'],_) ->
+    rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
     rnCmdTop body	         `thenM` \ (body',fvBody) ->
     returnM (HsProc pat' body', fvBody)
 
@@ -614,7 +614,7 @@ rnStmt ctxt (BindStmt pat expr _ _) thing_inside
 		-- The binders do not scope over the expression
 	; (bind_op, fvs1) <- lookupSyntaxName bindMName
 	; (fail_op, fvs2) <- lookupSyntaxName failMName
-	; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ ([pat'],_) -> do
+	; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
 	{ (thing, fvs3) <- thing_inside
 	; return ((BindStmt pat' expr' bind_op fail_op, thing),
 		  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
@@ -779,18 +779,12 @@ rn_rec_stmts_and_then s cont = do
 
   --    bring them and their fixities into scope
   let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
-  bindLocalNamesFV_WithFixities bound_names fix_env $ do
+  bindLocalNamesFV_WithFixities bound_names fix_env $ 
+    warnUnusedLocalBinds bound_names $ do
 
   -- (C) do the right-hand-sides and thing-inside
   segs <- rn_rec_stmts bound_names new_lhs_and_fv
-  (result, result_fvs) <- cont segs
-  
-  -- (D) warn about unusued binders                    
-  let unused_bndrs = [ b | b <- bound_names, not (b `elemNameSet` result_fvs)]
-  warnUnusedLocalBinds unused_bndrs
-
-  -- (E) return
-  return (result, result_fvs)
+  cont segs
 
 
 -- get all the fixity decls in any Let stmt
@@ -819,7 +813,7 @@ rn_rec_stmt_lhs fix_env (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt e
 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b)) 
   = do 
       -- should the ctxt be MDo instead?
-      (pat', fv_pat) <- rnPat_LocalRec fix_env pat 
+      (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat 
       return [(L loc (BindStmt pat' expr a b),
                fv_pat)]
 

compiler/rename/RnTypes.lhs

@@ -32,7 +32,7 @@ import RnEnv		( lookupOccRn, lookupBndrRn, lookupSyntaxName,
 			  lookupLocatedOccRn, lookupLocatedBndrRn,
 			  lookupLocatedGlobalOccRn, bindTyVarsRn, 
 			  lookupFixityRn, lookupTyFixityRn, lookupConstructorFields,
-			  lookupRecordBndr, mapFvRn, warnUnusedMatches,
+			  lookupRecordBndr, mapFvRn, 
 			  newIPNameRn, bindPatSigTyVarsFV)
 import TcRnMonad
 import RdrName