Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-7.6
http://hackage.haskell.org/trac/ghc/changeset/55a7aa89e2886232c8581d0978d8db162fbd7c79 >--------------------------------------------------------------- commit 55a7aa89e2886232c8581d0978d8db162fbd7c79 Author: Simon Peyton Jones <simo...@microsoft.com> Date: Fri Oct 19 12:01:04 2012 +0100 Improve reporting of duplicate signatures Fixes Trac #7338 >--------------------------------------------------------------- compiler/hsSyn/HsBinds.lhs | 16 -------------- compiler/rename/RnBinds.lhs | 49 +++++++++++++++++++++++++++++------------- 2 files changed, 34 insertions(+), 31 deletions(-) diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 26097df..15e19b9 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -574,22 +574,6 @@ signatures. Since some of the signatures contain a list of names, testing for equality is not enough -- we have to check if they overlap. \begin{code} -overlapHsSig :: Eq a => LSig a -> LSig a -> Bool -overlapHsSig sig1 sig2 = case (unLoc sig1, unLoc sig2) of - (FixSig (FixitySig n1 _), FixSig (FixitySig n2 _)) -> unLoc n1 == unLoc n2 - (IdSig n1, IdSig n2) -> n1 == n2 - (TypeSig ns1 _, TypeSig ns2 _) -> ns1 `overlaps_with` ns2 - (GenericSig ns1 _, GenericSig ns2 _) -> ns1 `overlaps_with` ns2 - (InlineSig n1 _, InlineSig n2 _) -> unLoc n1 == unLoc n2 - -- For specialisations, we don't have equality over HsType, so it's not - -- convenient to spot duplicate specialisations here. Check for this later, - -- when we're in Type land - (_other1, _other2) -> False - where - ns1 `overlaps_with` ns2 = not (null (intersect (map unLoc ns1) (map unLoc ns2))) -\end{code} - -\begin{code} instance (OutputableBndr name) => Outputable (Sig name) where ppr sig = ppr_sig sig diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 2c70698..a3fd9db 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -50,7 +50,7 @@ import Digraph ( SCC(..) ) import Bag import Outputable import FastString -import Data.List ( partition ) +import Data.List ( partition, sort ) import Maybes ( orElse ) import Control.Monad \end{code} @@ -641,15 +641,7 @@ renameSigs :: HsSigCtxt -> RnM ([LSig Name], FreeVars) -- Renames the signatures and performs error checks renameSigs ctxt sigs - = do { mapM_ dupSigDeclErr (findDupsEq overlapHsSig sigs) -- Duplicate - -- Check for duplicates on RdrName version, - -- because renamed version has unboundName for - -- not-in-scope binders, which gives bogus dup-sig errors - -- NB: in a class decl, a 'generic' sig is not considered - -- equal to an ordinary sig, so we allow, say - -- class C a where - -- op :: a -> a - -- default op :: Eq a => a -> a + = do { mapM_ dupSigDeclErr (findDupSigs sigs) ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs @@ -736,6 +728,32 @@ okHsSig ctxt (L _ sig) (SpecInstSig {}, InstDeclCtxt {}) -> True (SpecInstSig {}, _) -> False + +------------------- +findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]] +-- Check for duplicates on RdrName version, +-- because renamed version has unboundName for +-- not-in-scope binders, which gives bogus dup-sig errors +-- NB: in a class decl, a 'generic' sig is not considered +-- equal to an ordinary sig, so we allow, say +-- class C a where +-- op :: a -> a +-- default op :: Eq a => a -> a +findDupSigs sigs + = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) + where + expand_sig sig@(FixSig (FixitySig n _)) = [(n,sig)] + expand_sig sig@(InlineSig n _) = [(n,sig)] + expand_sig sig@(TypeSig ns _) = [(n,sig) | n <- ns] + expand_sig sig@(GenericSig ns _) = [(n,sig) | n <- ns] + expand_sig _ = [] + + matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 + mtch (FixSig {}) (FixSig {}) = True + mtch (InlineSig {}) (InlineSig {}) = True + mtch (TypeSig {}) (TypeSig {}) = True + mtch (GenericSig {}) (GenericSig {}) = True + mtch _ _ = False \end{code} @@ -819,14 +837,15 @@ rnGRHS' ctxt (GRHS guards rhs) %************************************************************************ \begin{code} -dupSigDeclErr :: [LSig RdrName] -> RnM () -dupSigDeclErr sigs@(L loc sig : _) +dupSigDeclErr :: [(Located RdrName, Sig RdrName)] -> RnM () +dupSigDeclErr pairs@((L loc name, sig) : _) = addErrAt loc $ - vcat [ptext (sLit "Duplicate") <+> what_it_is <> colon, - nest 2 (vcat (map ppr_sig sigs))] + vcat [ ptext (sLit "Duplicate") <+> what_it_is + <> ptext (sLit "s for") <+> quotes (ppr name) + , ptext (sLit "at") <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ] where what_it_is = hsSigDoc sig - ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig + dupSigDeclErr [] = panic "dupSigDeclErr" misplacedSigErr :: LSig Name -> RnM () _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
