Fix Trac #3943: incorrect unused-variable warning

In fixing this I did the usual little bit of refactoring

4 files changed, 41 insertions, 32 deletions

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 2cf2bdc4e3..bf4257da40 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -314,10 +314,11 @@ rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b)
 rnValBindsRHS :: NameSet  -- names bound by the LHSes
               -> HsValBindsLR Name RdrName
               -> RnM (HsValBinds Name, DefUses)
-rnValBindsRHS bound_names binds = 
-  rnValBindsRHSGen (\ fvs -> -- only keep the names the names from this group
-                    intersectNameSet bound_names fvs) bound_names binds
-
+rnValBindsRHS bound_names binds
+  = rnValBindsRHSGen trim bound_names binds
+  where
+    trim fvs = intersectNameSet bound_names fvs 
+	-- Only keep the names the names from this group
 
 -- for local binds
 -- wrapper that does both the left- and right-hand sides 
@@ -335,7 +336,8 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
 	; (bound_names, new_lhs) <- rnValBindsLHS new_fixities binds
 
 	      --     ...and bring them (and their fixities) into scope
-	; bindLocalNamesFV_WithFixities bound_names new_fixities $ do
+	; bindLocalNamesFV bound_names              $
+          addLocalFixities new_fixities bound_names $ do
 
 	{      -- (C) Do the RHS and thing inside
 	  (binds', dus) <- rnValBindsRHS (mkNameSet bound_names) new_lhs 
@@ -464,21 +466,22 @@ rnBind :: (Name -> [Name])		-- Signature tyvar function
 rnBind _ trim (L loc (PatBind { pat_lhs = pat,
                                 pat_rhs = grhss, 
                                 -- pat fvs were stored here while
-                                -- processing the LHS          
-                                bind_fvs=pat_fvs }))
+                                -- after processing the LHS          
+                                bind_fvs = pat_fvs }))
   = setSrcSpan loc $ 
     do	{let bndrs = collectPatBinders pat
 
 	; (grhss', fvs) <- rnGRHSs PatBindRhs grhss
 		-- No scoped type variables for pattern bindings
-	; let fvs' = trim fvs
+	; let all_fvs = pat_fvs `plusFV` fvs
+              fvs'    = trim all_fvs
 
 	; fvs' `seq` -- See Note [Free-variable space leak]
-      return (L loc (PatBind { pat_lhs = pat,
-                                  pat_rhs = grhss', 
-				     pat_rhs_ty = placeHolderType, 
-                                  bind_fvs = fvs' }),
-		  bndrs, pat_fvs `plusFV` fvs) }
+          return (L loc (PatBind { pat_lhs    = pat,
+                                   pat_rhs    = grhss', 
+				   pat_rhs_ty = placeHolderType, 
+                                   bind_fvs   = fvs' }),
+		  bndrs, all_fvs) }
 
 rnBind sig_fn 
        trim 
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index a4e6ab8497..69272801cd 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -20,7 +20,7 @@ module RnEnv (
 	newLocalBndrRn, newLocalBndrsRn, newIPNameRn,
 	bindLocalName, bindLocalNames, bindLocalNamesFV, 
 	MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
-	bindLocalNamesFV_WithFixities,
+	addLocalFixities,
 	bindLocatedLocalsFV, bindLocatedLocalsRn,
 	bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
 	bindTyVarsRn, extendTyVarEnvFVRn,
@@ -651,22 +651,17 @@ 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
-bindLocalNamesFV_WithFixities :: [Name]
-			      -> MiniFixityEnv
-			      -> RnM (a, FreeVars) -> RnM (a, FreeVars)
-bindLocalNamesFV_WithFixities names fixities thing_inside
-  = bindLocalNamesFV names $
-    extendFixityEnv boundFixities $ 
-    thing_inside
+
+addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
+addLocalFixities mini_fix_env names thing_inside
+  = extendFixityEnv (mapCatMaybes find_fixity names) thing_inside
   where
-    -- find the names that have fixity decls
-    boundFixities = foldr 
-                        (\ name -> \ acc -> 
-                         -- check whether this name has a fixity decl
-                          case lookupFsEnv fixities (occNameFS (nameOccName name)) of
-                               Just (L _ fix) -> (name, FixItem (nameOccName name) fix) : acc
-                               Nothing -> acc) [] names
-    -- bind the names; extend the fixity env; do the thing inside
+    find_fixity name 
+      = case lookupFsEnv mini_fix_env (occNameFS occ) of
+          Just (L _ fix) -> Just (name, FixItem occ fix)
+          Nothing        -> Nothing
+      where
+        occ = nameOccName name
 \end{code}
 
 --------------------------------
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index d1984f88ce..48f1e6fad7 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -886,7 +886,8 @@ rn_rec_stmts_and_then s cont
 
 	  --    ...bring them and their fixities into scope
 	; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
-	; bindLocalNamesFV_WithFixities bound_names fix_env $ do
+	; bindLocalNamesFV bound_names $
+          addLocalFixities fix_env bound_names $ do
 
 	  -- (C) do the right-hand-sides and thing-inside
 	{ segs <- rn_rec_stmts bound_names new_lhs_and_fv
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 813f39b8a1..58c2c34373 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -167,10 +167,12 @@ newName (LetMk mb_top fix_env) rdr_name
         do { name <- case mb_top of
                        Nothing  -> newLocalBndrRn rdr_name
                        Just mod -> newTopSrcBinder mod rdr_name
-	   ; bindLocalNamesFV_WithFixities [name] fix_env $
+	   ; bindLocalName name $	-- Do *not* use bindLocalNameFV here
+					-- See Note [View pattern usage]
+             addLocalFixities fix_env [name] $
 	     thing_inside name })
 			  
-    -- Note: the bindLocalNamesFV_WithFixities is somewhat suspicious 
+    -- Note: the bindLocalName is somewhat suspicious
     --       because it binds a top-level name as a local name.
     --       however, this binding seems to work, and it only exists for
     --       the duration of the patterns and the continuation;
@@ -178,6 +180,14 @@ newName (LetMk mb_top fix_env) rdr_name
     --       before going on to the RHSes (see RnSource.lhs).
 \end{code}
 
+Note [View pattern usage]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  let (r, (r -> x)) = x in ...
+Here the pattern binds 'r', and then uses it *only* in the view pattern.
+We want to "see" this use, and in let-bindings we collect all uses and
+report unused variables at the binding level. So we must use bindLocalName
+here, *not* bindLocalNameFV.  Trac #3943.
 
 %*********************************************************
 %*							*