Merge branch 'master' of http://darcs.haskell.org/ghc

Conflicts:
	compiler/coreSyn/CoreSubst.lhs
	compiler/rename/RnNames.lhs

6 files changed, 122 insertions, 84 deletions

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 86acfa46b0..2a1330370a 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -702,18 +702,18 @@ renameSig _ (IdSig x)
   = return (IdSig x)	  -- Actually this never occurs
 renameSig mb_names sig@(TypeSig vs ty)
   = do	{ new_vs <- mapM (lookupSigOccRn mb_names sig) vs
-	; new_ty <- rnHsSigType (quotes (ppr vs)) ty
+	; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty
 	; return (TypeSig new_vs new_ty) }
 
 renameSig mb_names sig@(GenericSig vs ty)
   = do	{ defaultSigs_on <- xoptM Opt_DefaultSignatures
         ; unless defaultSigs_on (addErr (defaultSigErr sig))
         ; new_v <- mapM (lookupSigOccRn mb_names sig) vs
-	; new_ty <- rnHsSigType (quotes (ppr vs)) ty
+	; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty
 	; return (GenericSig new_v new_ty) }
 
 renameSig _ (SpecInstSig ty)
-  = do	{ new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
+  = do	{ new_ty <- rnLHsType (text "In a SPECIALISE instance pragma") ty
 	; return (SpecInstSig new_ty) }
 
 -- {-# SPECIALISE #-} pragmas can refer to imported Ids
@@ -734,6 +734,9 @@ renameSig mb_names sig@(InlineSig v s)
 renameSig mb_names sig@(FixSig (FixitySig v f))
   = do	{ new_v <- lookupSigOccRn mb_names sig v
 	; return (FixSig (FixitySig new_v f)) }
+
+ppr_sig_bndrs :: [Located RdrName] -> SDoc
+ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
 \end{code}
 
 
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 58df462532..9374b5ca17 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -11,7 +11,8 @@ module RnEnv (
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
 	lookupLocalDataTcNames, lookupSigOccRn,
 	lookupFixityRn, lookupTyFixityRn, 
-	lookupInstDeclBndr, lookupSubBndr, lookupConstructorFields,
+	lookupInstDeclBndr, lookupSubBndr, 
+        lookupSubBndrGREs, lookupConstructorFields,
 	lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse,
 	lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
 	getLookupOccRn, addUsedRdrNames,
@@ -288,32 +289,19 @@ lookupSubBndr parent doc rdr_name
   = lookupOrig rdr_mod rdr_occ
 
   | otherwise	-- Find all the things the rdr-name maps to
-  = do	{	-- and pick the one with the right parent name
-	; env <- getGlobalRdrEnv
-        ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
-	; case pick parent gres  of
+  = do	{	-- and pick the one with the right parent namep
+	  env <- getGlobalRdrEnv
+	; case lookupSubBndrGREs env parent rdr_name of
 		-- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!
 		--     The latter does pickGREs, but we want to allow 'x'
 		--     even if only 'M.x' is in scope
 	    [gre] -> do { addUsedRdrName gre (used_rdr_name gre)
                         ; return (gre_name gre) }
 	    []    -> do { addErr (unknownSubordinateErr doc rdr_name)
-			; traceRn (text "RnEnv.lookup_sub_bndr" <+> (ppr rdr_name $$ ppr gres))
 			; return (mkUnboundName rdr_name) }
 	    gres  -> do { addNameClashErrRn rdr_name gres
 			; return (gre_name (head gres)) } }
   where
-    rdr_occ = rdrNameOcc rdr_name    
-
-    pick NoParent gres		-- Normal lookup 
-      = pickGREs rdr_name gres
-    pick (ParentIs p) gres	-- Disambiguating lookup
-      | isUnqual rdr_name = filter (right_parent p) gres
-      | otherwise         = filter (right_parent p) (pickGREs rdr_name gres)
-
-    right_parent p (GRE { gre_par = ParentIs p' }) = p==p' 
-    right_parent _ _                               = False
-
     -- Note [Usage for sub-bndrs]
     used_rdr_name gre
       | isQual rdr_name = rdr_name
@@ -328,7 +316,26 @@ lookupSubBndr parent doc rdr_name
       = 	    -- Only qualified imports available, so make up 
 		    -- a suitable qualifed name from the first imp_spec
         ASSERT( not (null imp_specs) )
-        mkRdrQual (is_as (is_decl (head imp_specs))) rdr_occ
+        mkRdrQual (is_as (is_decl (head imp_specs))) (rdrNameOcc rdr_name)
+
+lookupSubBndrGREs :: GlobalRdrEnv -> Parent -> RdrName -> [GlobalRdrElt]
+-- If Parent = NoParent, just do a normal lookup
+-- If Parent = Parent p then find all GREs that
+--   (a) have parent p
+--   (b) for Unqual, are in scope qualified or unqualified
+--       for Qual, are in scope with that qualification
+lookupSubBndrGREs env parent rdr_name
+  = case parent of
+      NoParent   -> pickGREs rdr_name gres
+      ParentIs p 
+        | isUnqual rdr_name -> filter (parent_is p) gres
+        | otherwise         -> filter (parent_is p) (pickGREs rdr_name gres)
+
+  where
+    gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
+
+    parent_is p (GRE { gre_par = ParentIs p' }) = p == p'
+    parent_is _ _                               = False
 
 newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
 newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
@@ -980,7 +987,7 @@ checkDupAndShadowedNames envs names
 -------------------------------------
 checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM ()
 checkShadowedOccs (global_env,local_env) loc_occs
-  = ifDOptM Opt_WarnNameShadowing $ 
+  = ifWOptM Opt_WarnNameShadowing $ 
     do	{ traceRn (text "shadow" <+> ppr loc_occs)
 	; mapM_ check_shadow loc_occs }
   where
@@ -1214,7 +1221,7 @@ mapFvRnCPS f (x:xs) cont = f x 		   $ \ x' ->
 \begin{code}
 warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
 warnUnusedTopBinds gres
-    = ifDOptM Opt_WarnUnusedBinds
+    = ifWOptM Opt_WarnUnusedBinds
     $ do isBoot <- tcIsHsBoot
          let noParent gre = case gre_par gre of
                             NoParent -> True
@@ -1230,9 +1237,9 @@ warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM ()
 warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds
 warnUnusedMatches    = check_unused Opt_WarnUnusedMatches
 
-check_unused :: DynFlag -> [Name] -> FreeVars -> RnM ()
+check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
 check_unused flag bound_names used_names
- = ifDOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names))
+ = ifWOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names))
 
 -------------------------
 --	Helpers
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index dfd4d3555c..c6c941c4ca 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -146,7 +146,7 @@ rnImports prel_imp_loc imports
              (source, ordinary) = partition is_source_import imports
              is_source_import (L _ (ImportDecl _ _ is_boot _ _ _ _)) = is_boot
 
-         ifDOptM Opt_WarnImplicitPrelude $
+         ifWOptM Opt_WarnImplicitPrelude $
              when (notNull prel_imports) $ addWarn (implicitPreludeWarn)
 
          stuff1 <- mapM (rnImportDecl this_mod True)  prel_imports
@@ -197,7 +197,7 @@ rnImportDecl this_mod implicit_prelude
         Just (False, _)       -> return () -- Explicit import list
         _  | implicit_prelude -> return ()
            | qual_only        -> return ()
-           | otherwise        -> ifDOptM Opt_WarnMissingImportList $
+           | otherwise        -> ifWOptM Opt_WarnMissingImportList $
                                  addWarn (missingImportListWarn imp_mod_name)
 
     iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg
@@ -277,9 +277,7 @@ rnImportDecl this_mod implicit_prelude
 
         -- Does this import mean we now require our own pkg
         -- to be trusted? See Note [Trust Own Package]
-        ptrust = trust == Sf_Trustworthy
-               || trust == Sf_TrustworthyWithSafeLanguage
-               || trust_pkg
+        ptrust = trust == Sf_Trustworthy || trust_pkg
 
         (dependent_mods, dependent_pkgs, pkg_trust_req)
            | pkg == thisPackage dflags =
@@ -335,7 +333,7 @@ rnImportDecl this_mod implicit_prelude
                    }
 
     -- Complain if we import a deprecated module
-    ifDOptM Opt_WarnWarningsDeprecations        (
+    ifWOptM Opt_WarnWarningsDeprecations        (
        case warns of
           WarnAll txt -> addWarn (moduleWarn imp_mod_name txt)
           _           -> return ()
@@ -692,11 +690,11 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails
             -- Warn when importing T(..) if T was exported abstractly
             checkDodgyImport stuff
                 | IEThingAll n <- ieRdr, (_, AvailTC _ [_]):_ <- stuff
-                = ifDOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n))
+                = ifWOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n))
                     -- NB. use the RdrName for reporting the warning
                 | IEThingAll {} <- ieRdr
                 , not (is_qual decl_spec)
-                = ifDOptM Opt_WarnMissingImportList $
+                = ifWOptM Opt_WarnMissingImportList $
                   addWarn (missingImportListItem ieRdr)
             checkDodgyImport _
                 = return ()
@@ -1023,13 +1021,13 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
                       (L loc (IEModuleContents mod))
         | let earlier_mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ]
         , mod `elem` earlier_mods    -- Duplicate export of M
-        = do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ;
+        = do { warn_dup_exports <- woptM Opt_WarnDuplicateExports ;
                warnIf warn_dup_exports (dupModuleExport mod) ;
                return acc }
 
         | otherwise
         = do { implicit_prelude <- xoptM Opt_ImplicitPrelude
-             ; warnDodgyExports <- doptM Opt_WarnDodgyExports
+             ; warnDodgyExports <- woptM Opt_WarnDodgyExports
              ; let { exportValid = (mod `elem` imported_modules)
                             || (moduleName this_mod == mod)
                    ; gres = filter (isModuleExported implicit_prelude mod)
@@ -1092,7 +1090,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
                                 Nothing -> mkRdrUnqual
                                 Just (modName, _) -> mkRdrQual modName
              addUsedRdrNames $ map (mkKidRdrName . nameOccName) kids
-             warnDodgyExports <- doptM Opt_WarnDodgyExports
+             warnDodgyExports <- woptM Opt_WarnDodgyExports
              when (null kids) $
                   if isTyConName name
                   then when warnDodgyExports $ addWarn (dodgyExportWarn name)
@@ -1175,7 +1173,7 @@ check_occs ie occs names  -- 'names' are the entities specifed by 'ie'
             -- But we don't want to warn if the same thing is exported
             -- by two different module exports. See ticket #4478.
             -> do unless (dupExport_ok name ie ie') $ do
-                      warn_dup_exports <- doptM Opt_WarnDuplicateExports
+                      warn_dup_exports <- woptM Opt_WarnDuplicateExports
                       warnIf warn_dup_exports (dupExportWarn name_occ ie ie')
                   return occs
 
@@ -1241,7 +1239,7 @@ finishWarnings :: DynFlags -> Maybe WarningTxt
 --     All this happens only once per module
 finishWarnings dflags mod_warn tcg_env
   = do  { (eps,hpt) <- getEpsAndHpt
-        ; ifDOptM Opt_WarnWarningsDeprecations $
+        ; ifWOptM Opt_WarnWarningsDeprecations $
           mapM_ (check hpt (eps_PIT eps)) all_gres
                 -- By this time, typechecking is complete,
                 -- so the PIT is fully populated
@@ -1397,7 +1395,7 @@ warnUnusedImportDecls gbl_env
 
        ; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr (Set.elems uses)
                        , ptext (sLit "Import usage") <+> ppr usage])
-       ; ifDOptM Opt_WarnUnusedImports $
+       ; ifWOptM Opt_WarnUnusedImports $
          mapM_ warnUnusedImport usage
 
        ; ifDOptM Opt_D_dump_minimal_imports $
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 3a60066342..8f99b33aad 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -47,7 +47,8 @@ import Name
 import NameSet
 import RdrName
 import BasicTypes
-import ListSetOps	( removeDups, minusList )
+import Util		( notNull )
+import ListSetOps	( removeDups )
 import Outputable
 import SrcLoc
 import FastString
@@ -468,15 +469,13 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
             Nothing  -> ptext (sLit "constructor field name")
             Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con)
 
-    name_to_arg (L loc n) = L loc (mk_arg (mkRdrUnqual (nameOccName n)))
-
     rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld
                        	      	     , hsRecFieldArg = arg
                        	      	     , hsRecPun = pun })
-      = do { fld' <- wrapLocM (lookupSubBndr parent doc) fld
+      = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndr parent doc) fld
            ; arg' <- if pun 
                      then do { checkErr pun_ok (badPun fld)
-                             ; return (name_to_arg fld') }
+                             ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) }
                      else return arg
            ; return (HsRecField { hsRecFieldId = fld'
                                 , hsRecFieldArg = arg'
@@ -491,30 +490,54 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
         do { loc <- getSrcSpanM	-- Rather approximate
            ; dd_flag <- xoptM Opt_RecordWildCards
            ; checkErr dd_flag (needFlagDotDot ctxt)
-
+	   ; (rdr_env, lcl_env) <- getRdrEnvs
            ; con_fields <- lookupConstructorFields con
            ; let present_flds = getFieldIds flds
-                 absent_flds  = con_fields `minusList` present_flds
+                 parent_tc = find_tycon rdr_env con
                  extras = [ HsRecField
-                              { hsRecFieldId = L loc f
-                              , hsRecFieldArg = name_to_arg (L loc f)
+                              { hsRecFieldId = loc_f
+                              , hsRecFieldArg = L loc (mk_arg arg_rdr)
                               , hsRecPun = False }
-                          | f <- absent_flds ]
+                          | f <- con_fields
+			  , let loc_f = L loc f 
+			        arg_rdr = mkRdrUnqual (nameOccName f)
+			  , not (f `elem` present_flds)
+			  , fld_in_scope f
+                          , case ctxt of
+                              HsRecFieldCon {} -> arg_in_scope arg_rdr
+                              _other           -> True ]
+
+                   -- Only fill in fields whose selectors are in scope (somehow)
+	         fld_in_scope fld = not (null (lookupGRE_Name rdr_env fld))
+
+                   -- For constructor uses, the arg should be in scope (unqualified)
+		   -- ignoring the record field itself
+		   -- Eg.  data R = R { x,y :: Int }
+                   --      f x = R { .. }   -- Should expand to R {x=x}, not R{x=x,y=y}
+		 arg_in_scope rdr = rdr `elemLocalRdrEnv` lcl_env
+                                 || notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env
+                                                  , case gre_par gre of
+                                                      ParentIs p -> p /= parent_tc
+                                                      _          -> True ]
 
            ; return (flds ++ extras) }
 
     check_disambiguation :: Bool -> Maybe Name -> RnM Parent
-    -- When disambiguation is on, return the parent *type constructor*
-    -- That is, the parent of the data constructor.  That's the parent
-    -- to use for looking up record fields.
+    -- When disambiguation is on, 
     check_disambiguation disambig_ok mb_con
       | disambig_ok, Just con <- mb_con
-      = do { env <- getGlobalRdrEnv
-           ; return (case lookupGRE_Name env con of
-	       	       [gre] -> gre_par gre
-               	       gres  -> WARN( True, ppr con <+> ppr gres ) NoParent) }
+      = do { env <- getGlobalRdrEnv; return (ParentIs (find_tycon env con)) }
       | otherwise = return NoParent
  
+    find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Name {- TyCon -}
+    -- Return the parent *type constructor* of the data constructor
+    -- That is, the parent of the data constructor.  
+    -- That's the parent to use for looking up record fields.
+    find_tycon env con 
+      = case lookupGRE_Name env con of
+	  [GRE { gre_par = ParentIs p }] -> p
+          gres  -> pprPanic "find_tycon" (ppr con $$ ppr gres)
+
     dup_flds :: [[RdrName]]
         -- Each list represents a RdrName that occurred more than once
         -- (the list contains all occurrences)
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 12d4375606..0ddfa0a2ae 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -19,7 +19,7 @@ import HsSyn
 import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
 import RdrHsSyn		( extractHsRhoRdrTyVars )
 import RnHsSyn
-import RnTypes		( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
+import RnTypes
 import RnBinds		( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
                                 makeMiniFixityEnv)
 import RnEnv		( lookupLocalDataTcNames, lookupLocatedOccRn,
@@ -169,7 +169,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    -- (H) Rename Everything else
 
    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
-   (rn_rule_decls,    src_fvs3) <- setOptM Opt_ScopedTypeVariables $
+   (rn_rule_decls,    src_fvs3) <- setXOptM Opt_ScopedTypeVariables $
                                    rnList rnHsRuleDecl    rule_decls ;
                            -- Inside RULES, scoped type variables are on
    (rn_vect_decls,    src_fvs4) <- rnList rnHsVectDecl    vect_decls ;
@@ -531,7 +531,7 @@ rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
 rnSrcDerivDecl (DerivDecl ty)
   = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
        ; unless standalone_deriv_ok (addErr standaloneDerivErr)
-       ; ty' <- rnLHsType (text "a deriving decl") ty
+       ; ty' <- rnLHsType (text "In a deriving declaration") ty
        ; let fvs = extractHsTyNames ty'
        ; return (DerivDecl ty', fvs) }
 
@@ -919,12 +919,16 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
         ; rdr_env <- getLocalRdrEnv
         ; let in_scope     = (`elemLocalRdrEnv` rdr_env) . unLoc
 	      arg_tys      = hsConDeclArgTys details
-	      implicit_tvs = case res_ty of
+	      mentioned_tvs = case res_ty of
 	      	    	       ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
 	      	    	       ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
-	      new_tvs = case expl of
-	        	  Explicit -> tvs
-		    	  Implicit -> userHsTyVarBndrs implicit_tvs
+
+         -- With an Explicit forall, check for unused binders
+	 -- With Implicit, find the mentioned ones, and use them as binders
+	; new_tvs <- case expl of
+	    	       Implicit -> return (userHsTyVarBndrs mentioned_tvs)
+            	       Explicit -> do { warnUnusedForAlls doc tvs mentioned_tvs
+                                      ; return tvs }
 
         ; mb_doc' <- rnMbLHsDoc mb_doc 
 
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index be90d7d0a9..392e411b37 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -11,7 +11,7 @@ module RnTypes (
 
 	-- Precence related stuff
 	mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
-	checkPrecMatch, checkSectionPrec,
+	checkPrecMatch, checkSectionPrec, warnUnusedForAlls,
 
 	-- Splice related stuff
 	rnSplice, checkTH
@@ -36,6 +36,7 @@ import Name
 import SrcLoc
 import NameSet
 
+import Util		( filterOut )
 import BasicTypes	( compareFixity, funTyFixity, negateFixity, 
 			  Fixity(..), FixityDirection(..) )
 import Outputable
@@ -93,19 +94,16 @@ rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do
 
     rnForAll doc Implicit tyvar_bndrs ctxt ty
 
-rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) = do
-	-- Explicit quantification.
-	-- Check that the forall'd tyvars are actually 
-	-- mentioned in the type, and produce a warning if not
-    let
-	mentioned	   = map unLoc (extractHsRhoRdrTyVars ctxt tau)
-	forall_tyvar_names = hsLTyVarLocNames forall_tyvars
-
-	-- Explicitly quantified but not mentioned in ctxt or tau
-	warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names
+rnHsType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau)
+  = do { 	-- Explicit quantification.
+         -- Check that the forall'd tyvars are actually 
+	 -- mentioned in the type, and produce a warning if not
+         let mentioned   = extractHsRhoRdrTyVars ctxt tau
+             in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
+       ; warnUnusedForAlls (in_type_doc $$ doc) forall_tyvars mentioned
 
-    mapM_ (forAllWarn doc tau) warn_guys
-    rnForAll doc Explicit forall_tyvars ctxt tau
+       ; -- rnForAll does the rest
+         rnForAll doc Explicit forall_tyvars ctxt tau }
 
 rnHsType _ (HsTyVar tyvar) = do
     tyvar' <- lookupOccRn tyvar
@@ -560,14 +558,19 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
 %*********************************************************
 
 \begin{code}
-forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
-           -> TcRnIf TcGblEnv TcLclEnv ()
-forAllWarn doc ty (L loc tyvar)
-  = ifDOptM Opt_WarnUnusedMatches 	$
-    addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar),
-		 	nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))]
-		   $$
-		   doc)
+warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [Located RdrName] -> TcM ()
+warnUnusedForAlls in_doc bound used
+  = ifWOptM Opt_WarnUnusedMatches $
+    mapM_ add_warn bound_but_not_used
+  where
+    bound_names        = hsLTyVarLocNames bound
+    bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names
+    mentioned_rdrs     = map unLoc used
+
+    add_warn (L loc tv) 
+      = addWarnAt loc $
+        vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv)
+             , in_doc ]
 
 opTyErr :: RdrName -> HsType RdrName -> SDoc
 opTyErr op ty@(HsOpTy ty1 _ _)