Fix Trac #3640, plus associated refactoring

In fixing this bug (to do with record puns), I had the usual rush of
blood to the head, and I did quite a bit of refactoring in the way
that duplicate/shadowed names are reported.

I think the result is shorter as well as clearer.

In one place I found it convenient for the renamer to use the ErrCtxt
carried in the monad.  (The renamer used not to have such a context,
but years ago the typechecker and renamer monads became one, so now it
does.)   So now it's availble if you want it in future.

7 files changed, 182 insertions, 201 deletions

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 12432a3d09..876f25aeac 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -158,9 +158,8 @@ rnTopBindsLHS :: MiniFixityEnv
               -> HsValBinds RdrName 
               -> RnM (HsValBindsLR Name RdrName)
 rnTopBindsLHS fix_env binds
-  = do { let (boundNames,doc) = bindersAndDoc binds 
-       ; mod <- getModule
-       ; rnValBindsLHSFromDoc (topRecNameMaker mod fix_env) boundNames doc binds }
+  = do { mod <- getModule
+       ; rnValBindsLHSFromDoc (topRecNameMaker mod fix_env) binds }
 
 rnTopBindsRHS :: NameSet	-- Names bound by these binds
               -> HsValBindsLR Name RdrName 
@@ -241,63 +240,46 @@ rnIPBind (IPBind n expr) = do
 %************************************************************************
 
 \begin{code}
--- wrapper for local binds
--- creates the documentation info and calls the helper below
+-- Renaming local binding gropus 
+-- Does duplicate/shadow check
 rnValBindsLHS :: MiniFixityEnv
               -> HsValBinds RdrName
-              -> RnM (HsValBindsLR Name RdrName)
-rnValBindsLHS fix_env binds = 
-    let (boundNames,doc) = bindersAndDoc binds 
-    in rnValBindsLHSFromDoc_Local boundNames doc fix_env binds
-
--- a helper used for local binds that does the duplicates check,
--- just so we don't forget to do it somewhere
-rnValBindsLHSFromDoc_Local :: [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice)
-                           -> SDoc              -- doc string for dup names and shadowing
-                           -> MiniFixityEnv
-                           -> HsValBinds RdrName
-                           -> RnM (HsValBindsLR Name RdrName)
-
-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.
-     checkDupAndShadowedRdrNames doc boundNames
-
-     -- (Note that we don't want to do this at the top level, since
-     -- sorting out duplicates and shadowing there happens elsewhere.
-     -- The behavior is even different. For example,
-     --   import A(f)
-     --   f = ...
-     -- should not produce a shadowing warning (but it will produce
-     -- an ambiguity warning if you use f), but
-     --   import A(f)
-     --   g = let f = ... in f
-     -- should.
-     rnValBindsLHSFromDoc (localRecNameMaker fix_env) boundNames doc binds 
-
-bindersAndDoc :: HsValBinds RdrName -> ([Located RdrName], SDoc)
-bindersAndDoc binds = 
-    let
-        -- the unrenamed bndrs for error checking and reporting
-        orig = collectHsValBinders binds
-        doc = text "In the binding group for:" <+> pprWithCommas ppr (map unLoc orig)
-    in
-      (orig, doc)
+              -> RnM ([Name], HsValBindsLR Name RdrName)
+rnValBindsLHS 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.
+         -- 
+     	 -- Note that we don't want to do this at the top level, since
+     	 -- sorting out duplicates and shadowing there happens elsewhere.
+     	 -- The behavior is even different. For example,
+     	 --   import A(f)
+     	 --   f = ...
+     	 -- should not produce a shadowing warning (but it will produce
+     	 -- an ambiguity warning if you use f), but
+     	 --   import A(f)
+     	 --   g = let f = ... in f
+     	 -- should.
+       ; binds' <- rnValBindsLHSFromDoc (localRecNameMaker fix_env) binds 
+       ; let bound_names = map unLoc $ collectHsValBinders binds'
+       ; envs <- getRdrEnvs
+       ; checkDupAndShadowedNames envs bound_names
+       ; return (bound_names, 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 :: NameMaker 
-                     -> [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice)
-                     -> SDoc              -- doc string for dup names and shadowing
                      -> HsValBinds RdrName
                      -> RnM (HsValBindsLR Name RdrName)
-rnValBindsLHSFromDoc topP _original_bndrs doc (ValBindsIn mbinds sigs) = do
-     -- rename the LHSes
-     mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
-     return $ ValBindsIn mbinds' sigs
-rnValBindsLHSFromDoc _ _ _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
+rnValBindsLHSFromDoc topP (ValBindsIn mbinds sigs)
+  = do { mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
+       ; return $ ValBindsIn mbinds' sigs }
+  where
+    bndrs = collectHsBindBinders mbinds
+    doc   = text "In the binding group for:" <+> pprWithCommas ppr bndrs
+
+rnValBindsLHSFromDoc _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
 
 -- General version used both from the top-level and for local things
 -- Assumes the LHS vars are in scope
@@ -310,16 +292,16 @@ rnValBindsRHSGen :: (FreeVars -> FreeVars)  -- for trimming free var sets
                  -> HsValBindsLR Name RdrName
                  -> RnM (HsValBinds Name, DefUses)
 
-rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) = do
-   -- rename the sigs
-   sigs' <- renameSigs (Just bound_names) okBindSig sigs
-   -- rename the RHSes
-   binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
-   case depAnalBinds binds_w_dus of
-       (anal_binds, anal_dus) ->
-           do let valbind' = ValBindsOut anal_binds sigs'
-                  valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus
-              return (valbind', valbind'_dus)
+rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs)
+  = do {  -- rename the sigs
+         sigs' <- renameSigs (Just bound_names) okBindSig sigs
+          -- rename the RHSes
+       ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
+       ; case depAnalBinds binds_w_dus of
+            (anal_binds, anal_dus) -> do
+       { let valbind' = ValBindsOut anal_binds sigs'
+             valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus
+       ; return (valbind', valbind'_dus) }}
 
 rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b)
 
@@ -346,14 +328,11 @@ rnValBindsAndThen :: HsValBinds RdrName
                   -> (HsValBinds Name -> RnM (result, FreeVars))
                   -> RnM (result, FreeVars)
 rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
- = do	{ let (original_bndrs, doc) = bindersAndDoc binds
-
-	      -- (A) Create the local fixity environment 
-	; new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs]
+ = do	{     -- (A) Create the local fixity environment 
+	  new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs]
 
 	      -- (B) Rename the LHSes 
-	; new_lhs <- rnValBindsLHSFromDoc_Local original_bndrs doc new_fixities binds
-	; let bound_names = map unLoc $ collectHsValBinders new_lhs
+	; (bound_names, new_lhs) <- rnValBindsLHS new_fixities binds
 
 	      --     ...and bring them (and their fixities) into scope
 	; bindLocalNamesFV_WithFixities bound_names new_fixities $ do
@@ -418,7 +397,7 @@ makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls
          Nothing -> return $ extendFsEnv env fs fix_item
          Just (L loc' _) -> do
            { setSrcSpan loc $ 
-             addLocErr (L name_loc name) (dupFixityDecl loc')
+             addErrAt name_loc (dupFixityDecl loc' name)
            ; return env}
      }
 
@@ -670,8 +649,8 @@ rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix =
 
 
 -- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBind _ _ _ mbind@(L _ (PatBind _ _ _ _)) = do
-    addLocErr mbind methodBindErr
+rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do
+    addErrAt loc (methodBindErr bind)
     return (emptyBag, emptyFVs)
 
 rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b)
@@ -765,8 +744,7 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
   = do 	{ 	-- Result type signatures are no longer supported
 	  case maybe_rhs_sig of	
 	        Nothing -> return ()
-	        Just ty -> addLocErr ty (resSigErr ctxt match)
-
+	        Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty)
 
 	       -- Now the main event
 	       -- note that there are no local ficity decls for matches
@@ -775,7 +753,6 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
 
 	; return (Match pats' Nothing grhss', grhss_fvs) }}
 	-- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
-  where
 
 resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc 
 resSigErr ctxt match ty
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 20d221857f..c81d701761 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -25,8 +25,8 @@ module RnEnv (
 	bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
 	bindTyVarsRn, extendTyVarEnvFVRn,
 
-	checkDupRdrNames, checkDupNames, checkShadowedNames, 
-	checkDupAndShadowedRdrNames,
+	checkDupRdrNames, checkDupAndShadowedRdrNames,
+        checkDupAndShadowedNames, 
 	mapFvRn, mapFvRnCPS,
 	warnUnusedMatches, warnUnusedModules, warnUnusedImports, 
 	warnUnusedTopBinds, warnUnusedLocalBinds,
@@ -795,20 +795,11 @@ newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
 newLocalBndrsRn = mapM newLocalBndrRn
 
 ---------------------
-checkDupAndShadowedRdrNames :: SDoc -> [Located RdrName] -> RnM ()
-checkDupAndShadowedRdrNames doc loc_rdr_names
-  = do	{ checkDupRdrNames doc loc_rdr_names
-	; envs <- getRdrEnvs
-	; checkShadowedNames doc envs 
-		[(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names] }
-
----------------------
-bindLocatedLocalsRn :: SDoc	-- Documentation string for error message
-	            -> [Located RdrName]
+bindLocatedLocalsRn :: [Located RdrName]
 	    	    -> ([Name] -> RnM a)
 	    	    -> RnM a
-bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
-  = do { checkDupAndShadowedRdrNames doc_str rdr_names_w_loc
+bindLocatedLocalsRn rdr_names_w_loc enclosed_scope
+  = do { checkDupAndShadowedRdrNames rdr_names_w_loc
 
 	-- Make fresh Names and extend the environment
        ; names <- newLocalBndrsRn rdr_names_w_loc
@@ -835,20 +826,20 @@ bindLocalNamesFV names enclosed_scope
 -------------------------------------
 	-- binLocalsFVRn is the same as bindLocalsRn
 	-- except that it deals with free vars
-bindLocatedLocalsFV :: SDoc -> [Located RdrName] 
+bindLocatedLocalsFV :: [Located RdrName] 
                     -> ([Name] -> RnM (a,FreeVars)) -> RnM (a, FreeVars)
-bindLocatedLocalsFV doc rdr_names enclosed_scope
-  = bindLocatedLocalsRn doc rdr_names	$ \ names ->
+bindLocatedLocalsFV rdr_names enclosed_scope
+  = bindLocatedLocalsRn rdr_names	$ \ names ->
     enclosed_scope names		`thenM` \ (thing, fvs) ->
     return (thing, delListFromNameSet fvs names)
 
 -------------------------------------
-bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName]
+bindTyVarsRn ::  [LHsTyVarBndr RdrName]
 	      -> ([LHsTyVarBndr Name] -> RnM a)
 	      -> RnM a
 -- Haskell-98 binding of type variables; e.g. within a data type decl
-bindTyVarsRn doc_str tyvar_names enclosed_scope
-  = bindLocatedLocalsRn doc_str located_tyvars	$ \ names ->
+bindTyVarsRn tyvar_names enclosed_scope
+  = bindLocatedLocalsRn located_tyvars	$ \ names ->
     do { kind_sigs_ok <- doptM Opt_KindSignatures
        ; unless (null kinded_tyvars || kind_sigs_ok) 
        	 	(mapM_ (addErr . kindSigErr) kinded_tyvars)
@@ -875,9 +866,7 @@ bindPatSigTyVars tys thing_inside
 		--	f (x :: t) (y :: t) = ....
 		-- We don't want to complain about binding t twice!
 
-	; bindLocatedLocalsRn doc_sig nubbed_tvs thing_inside }}
-  where
-    doc_sig = text "In a pattern type-signature"
+	; bindLocatedLocalsRn nubbed_tvs thing_inside }}
 
 bindPatSigTyVarsFV :: [LHsType RdrName]
 		   -> RnM (a, FreeVars)
@@ -902,30 +891,42 @@ extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
 extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside
 
 -------------------------------------
-checkDupRdrNames :: SDoc
-	         -> [Located RdrName]
-	         -> RnM ()
-checkDupRdrNames doc_str rdr_names_w_loc
+checkDupRdrNames :: [Located RdrName] -> RnM ()
+checkDupRdrNames rdr_names_w_loc
   = 	-- Check for duplicated names in a binding group
-    mapM_ (dupNamesErr getLoc doc_str) dups
+    mapM_ (dupNamesErr getLoc) dups
   where
     (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
 
-checkDupNames :: SDoc
-	      -> [Name]
-	      -> RnM ()
-checkDupNames doc_str names
+checkDupNames :: [Name] -> RnM ()
+checkDupNames names
   = 	-- Check for duplicated names in a binding group
-    mapM_ (dupNamesErr nameSrcSpan doc_str) dups
+    mapM_ (dupNamesErr nameSrcSpan) dups
   where
     (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
 
+---------------------
+checkDupAndShadowedRdrNames :: [Located RdrName] -> RnM ()
+checkDupAndShadowedRdrNames loc_rdr_names
+  = do	{ checkDupRdrNames loc_rdr_names
+	; envs <- getRdrEnvs
+	; checkShadowedOccs envs loc_occs }
+  where
+    loc_occs = [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names]
+
+checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
+checkDupAndShadowedNames envs names
+  = do { checkDupNames names
+       ; checkShadowedOccs envs loc_occs }
+  where
+    loc_occs = [(nameSrcSpan name, nameOccName name) | name <- names]
+
 -------------------------------------
-checkShadowedNames :: SDoc -> (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM ()
-checkShadowedNames doc_str (global_env,local_env) loc_rdr_names
+checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM ()
+checkShadowedOccs (global_env,local_env) loc_occs
   = ifOptM Opt_WarnNameShadowing $ 
-    do	{ traceRn (text "shadow" <+> ppr loc_rdr_names)
-	; mapM_ check_shadow loc_rdr_names }
+    do	{ traceRn (text "shadow" <+> ppr loc_occs)
+	; mapM_ check_shadow loc_occs }
   where
     check_shadow (loc, occ)
         | startsWithUnderscore occ = return ()	-- Do not report shadowing for "_x"
@@ -935,7 +936,7 @@ checkShadowedNames doc_str (global_env,local_env) loc_rdr_names
 			 ; complain (map pprNameProvenance gres') }
 	where
 	  complain []      = return ()
-	  complain pp_locs = addWarnAt loc (shadowedNameWarn doc_str occ pp_locs)
+	  complain pp_locs = addWarnAt loc (shadowedNameWarn occ pp_locs)
 	  mb_local = lookupLocalRdrOcc local_env occ
           gres     = lookupGRE_RdrName (mkRdrUnqual occ) global_env
 		-- Make an Unqualified RdrName and look that up, so that
@@ -1070,12 +1071,11 @@ 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 :: SDoc -> OccName -> [SDoc] -> SDoc
-shadowedNameWarn doc occ shadowed_locs
+shadowedNameWarn :: OccName -> [SDoc] -> SDoc
+shadowedNameWarn occ shadowed_locs
   = sep [ptext (sLit "This binding for") <+> quotes (ppr occ)
 	    <+> ptext (sLit "shadows the existing binding") <> plural shadowed_locs,
 	 nest 2 (vcat shadowed_locs)]
-    $$ doc
 
 unknownNameErr :: RdrName -> SDoc
 unknownNameErr rdr_name
@@ -1102,18 +1102,15 @@ badOrigBinding name
   = ptext (sLit "Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name)
 	-- The rdrNameOcc is because we don't want to print Prelude.(,)
 
-dupNamesErr :: Outputable n => (n -> SrcSpan) -> SDoc -> [n] -> RnM ()
-dupNamesErr get_loc descriptor names
+dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM ()
+dupNamesErr get_loc names
   = addErrAt big_loc $
     vcat [ptext (sLit "Conflicting definitions for") <+> quotes (ppr (head names)),
-	  locations, descriptor]
+	  locations]
   where
     locs      = map get_loc names
     big_loc   = foldr1 combineSrcSpans locs
-    one_line  = isOneLineSpan big_loc
-    locations | one_line  = empty 
-	      | otherwise = ptext (sLit "Bound at:") <+> 
-			    vcat (map ppr (sortLe (<=) locs))
+    locations = ptext (sLit "Bound at:") <+> vcat (map ppr (sortLe (<=) locs))
 
 kindSigErr :: Outputable a => a -> SDoc
 kindSigErr thing
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 4ce71826f6..a269dd5098 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -950,7 +950,7 @@ rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 
 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) 
-    = do binds' <- rnValBindsLHS fix_env binds
+    = do (_bound_names, binds') <- rnValBindsLHS fix_env binds
          return [(L loc (LetStmt (HsValBinds binds')),
                  -- Warning: this is bogus; see function invariant
                  emptyFVs
@@ -975,15 +975,14 @@ rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
 rn_rec_stmts_lhs :: MiniFixityEnv
                  -> [LStmt RdrName] 
                  -> RnM [(LStmtLR Name RdrName, FreeVars)]
-rn_rec_stmts_lhs fix_env stmts = 
-    let boundNames = collectLStmtsBinders stmts
-        doc = text "In a recursive mdo-expression"
-    in do
-     -- First do error checking: we need to check for dups here because we
-     -- don't bind all of the variables from the Stmt at once
-     -- with bindLocatedLocals.
-     checkDupRdrNames doc boundNames
-     mapM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> return (concat ls)
+rn_rec_stmts_lhs fix_env stmts
+  = do { let boundNames = collectLStmtsBinders stmts
+            -- First do error checking: we need to check for dups here because we
+            -- don't bind all of the variables from the Stmt at once
+            -- with bindLocatedLocals.
+       ; checkDupRdrNames boundNames
+       ; ls <- mapM (rn_rec_stmt_lhs fix_env) stmts
+       ; return (concat ls) }
 
 
 -- right-hand-sides
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 6ab4890b66..6367255350 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -220,9 +220,7 @@ rnPats ctxt pats thing_inside
 	         -- Nor can we check incrementally for shadowing, else we'll
 	         -- 	complain *twice* about duplicates e.g. f (x,x) = ...
         ; let names = collectPatsBinders pats'
-        ; checkDupNames doc_pat names
-	; checkShadowedNames doc_pat envs_before
-			     [(nameSrcSpan name, nameOccName name) | name <- names]
+        ; addErrCtxt doc_pat $ checkDupAndShadowedNames envs_before names
         ; thing_inside pats' } }
   where
     doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 6b49391662..9842d4533e 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -299,9 +299,10 @@ rnSrcWarnDecls _bound_names []
 
 rnSrcWarnDecls bound_names decls 
   = do { -- check for duplicates
-       ; mapM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups
-       ; mapM (addLocM rn_deprec) decls	`thenM` \ pairs_s ->
-         return (WarnSome ((concat pairs_s))) }
+       ; mapM_ (\ (L loc rdr:lrdr':_) -> addErrAt loc (dupWarnDecl lrdr' rdr)) 
+               warn_rdr_dups
+       ; pairs_s <- mapM (addLocM rn_deprec) decls
+       ; return (WarnSome ((concat pairs_s))) }
  where
    rn_deprec (Warning rdr_name txt)
        -- ensures that the names are defined locally
@@ -400,11 +401,10 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	-- The typechecker (not the renamer) checks that all 
 	-- the bindings are for the right class
     let
-	meth_doc    = text "In the bindings in an instance declaration"
 	meth_names  = collectHsBindLocatedBinders mbinds
 	(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
     in
-    checkDupRdrNames meth_doc meth_names 	`thenM_`
+    checkDupRdrNames meth_names 	`thenM_`
 	-- Check that the same method is not given twice in the
 	-- same instance decl	instance C T where
 	--			      f x = ...
@@ -424,10 +424,9 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	-- The typechecker (not the renamer) checks that all 
 	-- the declarations are for the right class
     let
-	at_doc   = text "In the associated types of an instance declaration"
 	at_names = map (head . tyClDeclNames . unLoc) ats
     in
-    checkDupRdrNames at_doc at_names		`thenM_`
+    checkDupRdrNames at_names		`thenM_`
 	-- See notes with checkDupRdrNames for methods, above
 
     rnATInsts ats				`thenM` \ (ats', at_fvs) ->
@@ -521,7 +520,7 @@ standaloneDerivErr
 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)	$
-    bindLocatedLocalsFV doc (map get_var vars)		$ \ ids ->
+    bindLocatedLocalsFV (map get_var vars)		$ \ ids ->
     do	{ (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
 		-- NB: The binders in a rule are always Ids
 		--     We don't (yet) support type variables
@@ -661,7 +660,7 @@ rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 	; checkTc (h98_style || null (unLoc context)) 
                   (badGadtStupidTheta tycon)
     	; (tyvars', context', typats', derivs', deriv_fvs)
-		<- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
+		<- bindTyVarsRn tyvars $ \ tyvars' -> do
 		         	 -- Checks for distinct tyvars
 		   { typats' <- rnTyPats data_doc typatsMaybe
                    ; context' <- rnContext data_doc context
@@ -703,21 +702,21 @@ rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 -- "type" and "type instance" declarations
 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
 			      tcdTyPats = typatsMaybe, tcdSynRhs = ty})
-  = do { bindTyVarsRn syn_doc tyvars                    $ \ tyvars' -> do
-         	 -- Checks for distinct tyvars
-       { name' <- if isFamInstDecl tydecl
-		  then lookupLocatedOccRn     name -- may be imported family
-		  else lookupLocatedTopBndrRn name
-       ; typats' <- rnTyPats syn_doc typatsMaybe
-       ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
-       ; return (TySynonym {tcdLName = name', tcdTyVars = tyvars', 
-			     tcdTyPats = typats', tcdSynRhs = ty'},
-	          delFVs (map hsLTyVarName tyvars') $
-		  fvs			      `plusFV`
-		   (if isFamInstDecl tydecl
-		   then unitFV (unLoc name')	-- type instance => use
-		   else emptyFVs))
-       } }
+  = bindTyVarsRn tyvars $ \ tyvars' -> do
+    {    	 -- Checks for distinct tyvars
+      name' <- if isFamInstDecl tydecl
+    		  then lookupLocatedOccRn     name -- may be imported family
+    		  else lookupLocatedTopBndrRn name
+    ; typats' <- rnTyPats syn_doc typatsMaybe
+    ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
+    ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' 
+    			, tcdTyPats = typats', tcdSynRhs = ty'},
+    	      delFVs (map hsLTyVarName tyvars') $
+    	      fvs			      `plusFV`
+    	       (if isFamInstDecl tydecl
+    	       then unitFV (unLoc name')	-- type instance => use
+    	       else emptyFVs))
+    }
   where
     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 
@@ -728,7 +727,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 
 	-- Tyvars scope over superclass context and method signatures
 	; (tyvars', context', fds', ats', ats_fvs, sigs')
-	    <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
+	    <- bindTyVarsRn tyvars $ \ tyvars' -> do
          	 -- Checks for distinct tyvars
 	     { context' <- rnContext cls_doc context
 	     ; fds' <- rnFds cls_doc fds
@@ -742,7 +741,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 	-- Check the signatures
 	-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 	; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
-	; checkDupRdrNames sig_doc sig_rdr_names_w_locs
+	; checkDupRdrNames sig_rdr_names_w_locs
 		-- Typechecker is responsible for checking that we only
 		-- give default-method bindings for things in this class.
 		-- The renamer *could* check this for class decls, but can't
@@ -782,7 +781,6 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 	     	  ats_fvs) }
   where
     cls_doc  = text "In the declaration for class" 	<+> ppr cname
-    sig_doc  = text "In the signatures for class"  	<+> ppr cname
 
 badGadtStupidTheta :: Located RdrName -> SDoc
 badGadtStupidTheta _
@@ -834,7 +832,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
 
         ; mb_doc' <- rnMbLHsDoc mb_doc 
 
-        ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
+        ; bindTyVarsRn new_tvs $ \new_tyvars -> do
 	{ new_context <- rnContext doc cxt
 	; new_details <- rnConDeclDetails doc details
         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
@@ -892,7 +890,7 @@ rnConDeclDetails doc (RecCon fields)
 --   are usage occurences for associated types.
 --
 rnFamily :: TyClDecl RdrName 
-         -> (SDoc -> [LHsTyVarBndr RdrName] -> 
+         -> ([LHsTyVarBndr RdrName] -> 
 	     ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 	     RnM (TyClDecl Name, FreeVars))
          -> RnM (TyClDecl Name, FreeVars)
@@ -900,7 +898,7 @@ rnFamily :: TyClDecl RdrName
 rnFamily (tydecl@TyFamily {tcdFlavour = flavour, 
 			   tcdLName = tycon, tcdTyVars = tyvars}) 
         bindIdxVars =
-      do { bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
+      do { bindIdxVars tyvars $ \tyvars' -> do {
 	 ; tycon' <- lookupLocatedTopBndrRn tycon
 	 ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon', 
 			      tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, 
@@ -908,9 +906,6 @@ rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
          } }
 rnFamily d _ = pprPanic "rnFamily" (ppr d)
 
-family_doc :: Located RdrName -> SDoc
-family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
-
 -- Rename associated type declarations (in classes)
 --
 -- * This can be family declarations and (default) type instances
@@ -925,7 +920,7 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
         rnTyClDecl tydecl
     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 
-    lookupIdxVars _ tyvars cont = 
+    lookupIdxVars tyvars cont = 
       do { checkForDups tyvars;
 	 ; tyvars' <- mapM lookupIdxVar tyvars
 	 ; cont tyvars'
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 62b778d5f8..b739d6d3a8 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -213,7 +213,7 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
 	-- of kind *.
 
 rnForAll doc exp forall_tyvars ctxt ty
-  = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do
+  = bindTyVarsRn forall_tyvars $ \ new_tyvars -> do
     new_ctxt <- rnContext doc ctxt
     new_ty <- rnLHsType doc ty
     return (HsForAllTy exp new_tyvars new_ctxt new_ty)
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index ad741336da..90028bdbe1 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -454,6 +454,7 @@ wrapLocSndM fn (L loc a) =
     return (b, L loc c)
 \end{code}
 
+Reporting errors
 
 \begin{code}
 getErrsVar :: TcRn (TcRef Messages)
@@ -468,49 +469,26 @@ addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
 failWith :: Message -> TcRn a
 failWith msg = addErr msg >> failM
 
-addLocErr :: Located e -> (e -> Message) -> TcRn ()
-addLocErr (L loc e) fn = addErrAt loc (fn e)
-
 addErrAt :: SrcSpan -> Message -> TcRn ()
-addErrAt loc msg = addLongErrAt loc msg empty
-
-addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
-addLongErrAt loc msg extra
-  = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;	
-	 errs_var <- getErrsVar ;
-	 rdr_env <- getGlobalRdrEnv ;
-         dflags <- getDOpts ;
-	 let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
-	 (warns, errs) <- readMutVar errs_var ;
-  	 writeMutVar errs_var (warns, errs `snocBag` err) }
+-- addErrAt is mainly (exclusively?) used by the renamer, where
+-- tidying is not an issue, but it's all lazy so the extra
+-- work doesn't matter
+addErrAt loc msg = do { ctxt <- getErrCtxt 
+	     	      ; tidy_env <- tcInitTidyEnv
+                      ; err_info <- mkErrInfo tidy_env ctxt
+	              ; addLongErrAt loc msg err_info }
 
 addErrs :: [(SrcSpan,Message)] -> TcRn ()
 addErrs msgs = mapM_ add msgs
 	     where
 	       add (loc,msg) = addErrAt loc msg
 
-addReport :: Message -> Message -> TcRn ()
-addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info
-
-addReportAt :: SrcSpan -> Message -> Message -> TcRn ()
-addReportAt loc msg extra_info
-  = do { errs_var <- getErrsVar ;
-	 rdr_env <- getGlobalRdrEnv ;
-         dflags <- getDOpts ;
-	 let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
-	                            msg extra_info } ;
-	 (warns, errs) <- readMutVar errs_var ;
-  	 writeMutVar errs_var (warns `snocBag` warn, errs) }
-
 addWarn :: Message -> TcRn ()
 addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty
 
 addWarnAt :: SrcSpan -> Message -> TcRn ()
 addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty
 
-addLocWarn :: Located e -> (e -> Message) -> TcRn ()
-addLocWarn (L loc e) fn = addReportAt loc (fn e) empty
-
 checkErr :: Bool -> Message -> TcRn ()
 -- Add the error if the bool is False
 checkErr ok msg = unless ok (addErr msg)
@@ -542,6 +520,38 @@ discardWarnings thing_inside
 \end{code}
 
 
+%************************************************************************
+%*									*
+	Shared error message stuff: renamer and typechecker
+%*									*
+%************************************************************************
+
+\begin{code}
+addReport :: Message -> Message -> TcRn ()
+addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info
+
+addReportAt :: SrcSpan -> Message -> Message -> TcRn ()
+addReportAt loc msg extra_info
+  = do { errs_var <- getErrsVar ;
+	 rdr_env <- getGlobalRdrEnv ;
+         dflags <- getDOpts ;
+	 let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
+	                            msg extra_info } ;
+	 (warns, errs) <- readMutVar errs_var ;
+  	 writeMutVar errs_var (warns `snocBag` warn, errs) }
+
+addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
+addLongErrAt loc msg extra
+  = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;	
+	 errs_var <- getErrsVar ;
+	 rdr_env <- getGlobalRdrEnv ;
+         dflags <- getDOpts ;
+	 let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
+	 (warns, errs) <- readMutVar errs_var ;
+  	 writeMutVar errs_var (warns, errs `snocBag` err) }
+\end{code}
+
+
 \begin{code}
 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
 -- Does try_m, with a debug-trace on failure
@@ -674,8 +684,7 @@ failIfErrsM = ifErrsM failM (return ())
 
 %************************************************************************
 %*									*
-	Context management and error message generation
-	  	    for the type checker
+	Context management for the type checker
 %*									*
 %************************************************************************
 
@@ -720,6 +729,12 @@ setInstCtxt (InstLoc _ src_loc ctxt) thing_inside
   = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
 \end{code}
 
+%************************************************************************
+%*									*
+	     Error message generation (type checker)
+%*									*
+%************************************************************************
+
     The addErrTc functions add an error message, but do not cause failure.
     The 'M' variants pass a TidyEnv that has already been used to
     tidy up the message; we then use it to tidy the context messages