[commit: ghc] ghc-7.2: Report on unused type variables (fixes #5331) (4da2f23)
Ian Lynagh
igloo at earth.li
Wed Jul 20 23:22:12 CEST 2011
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : ghc-7.2
http://hackage.haskell.org/trac/ghc/changeset/4da2f2312bb21a25763e521f138b919619a69f89
>---------------------------------------------------------------
commit 4da2f2312bb21a25763e521f138b919619a69f89
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Wed Jul 20 15:31:40 2011 +0100
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 | 9 +++++--
compiler/rename/RnSource.lhs | 16 +++++++++-----
compiler/rename/RnTypes.lhs | 45 ++++++++++++++++++++++-------------------
3 files changed, 40 insertions(+), 30 deletions(-)
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 86acfa4..2a13303 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/RnSource.lhs b/compiler/rename/RnSource.lhs
index 18c2048..0ddfa0a 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,
@@ -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 dd55f6f..392e411 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)
- = 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 _ _)
More information about the Cvs-ghc
mailing list