Report on unused type variables (fixes #5331)

We were doing this already for explicit types like
   f :: forall a. Int
but not for constructor declarations.  This patch
makes it consistent.

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}
 
 

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,
@@ -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 
 

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)
-  = ifWOptM 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 _ _)