[commit: ghc] master: Improve reporting of duplicate signatures (2726033)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/27260333c8ef58137e8b3b17fe332725f62c932f

>---------------------------------------------------------------

commit 27260333c8ef58137e8b3b17fe332725f62c932f
Author: Simon Peyton Jones <[email protected]>
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 f15ef5d..24ed16f 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 a0aea6a..480c023 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}
@@ -653,15 +653,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
 
@@ -748,6 +740,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}
 
 
@@ -848,14 +866,15 @@ rnGRHS' ctxt rnBody (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 ()