Ticket #7338: 0001-Rework-detection-of-duplicate-signatures-fixes-7338.patch

File 0001-Rework-detection-of-duplicate-signatures-fixes-7338.patch, 6.0 KB (added by michalt, 18 months ago)
  • compiler/hsSyn/HsBinds.lhs

    From 0ed340e7936fa5d6bf3da3ac34197c4015013edb Mon Sep 17 00:00:00 2001
    From: Michal Terepeta <michal.terepeta@gmail.com>
    Date: Mon, 22 Oct 2012 19:01:38 +0200
    Subject: [PATCH] Rework detection of duplicate signatures (fixes #7338)
    
    ---
     compiler/hsSyn/HsBinds.lhs  | 60 +++++++++++++++++++++++++++++++++------------
     compiler/rename/RnBinds.lhs | 23 +++++++++--------
     2 files changed, 58 insertions(+), 25 deletions(-)
    
    diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
    index f15ef5d..440c1ad 100644
    a b import SrcLoc 
    3737import Var 
    3838import Bag 
    3939import FastString 
     40import RdrName ( RdrName ) 
     41import ListSetOps ( findDupsEq ) 
    4042 
    4143import Data.Data hiding ( Fixity ) 
    4244import Data.List 
    4345import Data.Ord 
     46 
     47import qualified Data.Map as Map 
    4448\end{code} 
    4549 
    4650%************************************************************************ 
    hsSigDoc (SpecInstSig {}) = ptext (sLit "SPECIALISE instance pragma") 
    569573hsSigDoc (FixSig {})            = ptext (sLit "fixity declaration") 
    570574\end{code} 
    571575 
    572 Check if signatures overlap; this is used when checking for duplicate 
    573 signatures. Since some of the signatures contain a list of names, testing for 
    574 equality is not enough -- we have to check if they overlap. 
     576For each 'RdrName' or 'Id' we try to find duplicate signatures.  We generate a 
     577list of pairs of name and duplicate signatures that refer to that name. 
     578Different kind of duplicate signature (e.g., type signatures and INLINE 
     579signatures, etc.) are reported as separate pairs.  Also the list of duplicated 
     580signatures, for a given name, may have just one element, e.g., when we have 
     581  a, a :: Type 
     582there is no point in repeating the same signature. 
    575583 
    576584\begin{code} 
    577 overlapHsSig :: Eq a => LSig a -> LSig a -> Bool 
    578 overlapHsSig sig1 sig2 = case (unLoc sig1, unLoc sig2) of 
    579   (FixSig (FixitySig n1 _), FixSig (FixitySig n2 _)) -> unLoc n1 == unLoc n2 
    580   (IdSig n1,                IdSig n2)                -> n1 == n2 
    581   (TypeSig ns1 _,           TypeSig ns2 _)           -> ns1 `overlaps_with` ns2 
    582   (GenericSig ns1 _,        GenericSig ns2 _)        -> ns1 `overlaps_with` ns2 
    583   (InlineSig n1 _,          InlineSig n2 _)          -> unLoc n1 == unLoc n2 
    584   -- For specialisations, we don't have equality over HsType, so it's not 
    585   -- convenient to spot duplicate specialisations here.  Check for this later, 
    586   -- when we're in Type land 
    587   (_other1,                 _other2)                 -> False 
     585getDuplicateHsSigs :: [LSig RdrName] -> [(Either RdrName Id, [LSig RdrName])] 
     586getDuplicateHsSigs signatures = duplicates 
    588587  where 
    589     ns1 `overlaps_with` ns2 = not (null (intersect (map unLoc ns1) (map unLoc ns2))) 
     588    duplicates = concatMap getDuplicates $ Map.toList nameMap 
     589 
     590    getDuplicates (name, sigs) = 
     591      [ (name, nubBy identicalSig dupSigs) 
     592        | dupSigs <- findDupsEq sameSigKind sigs, length dupSigs > 1 ] 
     593 
     594    identicalSig (L l1 _) (L l2 _) = l1 == l2 
     595 
     596    nameMap = foldl' insertNames Map.empty signatures 
     597 
     598    insertNames nmap sig = case unLoc sig of 
     599      FixSig (FixitySig n _) -> insert (Left $ unLoc n) sig nmap 
     600      IdSig n                -> insert (Right n) sig nmap 
     601      TypeSig ns _           -> insertList (map (Left . unLoc) ns) sig nmap 
     602      GenericSig ns _        -> insertList (map (Left . unLoc) ns) sig nmap 
     603      InlineSig n _          -> insert (Left $ unLoc n) sig nmap 
     604      -- For specialisations, we don't have equality over HsType, so it's not 
     605      -- convenient to spot duplicate specialisations here.  Check for this 
     606      -- later, when we're in Type land 
     607      _                      -> nmap 
     608 
     609    insert n s = Map.insertWith (++) n [s] 
     610 
     611    insertList ns sig nmap = foldl' (\m n -> insert n sig m) nmap ns 
     612 
     613    sameSigKind sig1 sig2 = case (unLoc sig1, unLoc sig2) of 
     614      (FixSig _,        FixSig _)       -> True 
     615      (IdSig _,         IdSig _)        -> True 
     616      (TypeSig _ _,     TypeSig _ _)    -> True 
     617      (GenericSig _ _,  GenericSig _ _) -> True 
     618      (InlineSig _ _,   InlineSig _ _)  -> True 
     619      _                                 -> False 
    590620\end{code} 
    591621 
    592622\begin{code} 
  • compiler/rename/RnBinds.lhs

    diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
    index dfead07..653fa0f 100644
    a b import Name 
    4343import NameEnv 
    4444import NameSet 
    4545import RdrName          ( RdrName, rdrNameOcc ) 
     46import Var              ( Var ) 
    4647import SrcLoc 
    47 import ListSetOps       ( findDupsEq ) 
    4848import BasicTypes       ( RecFlag(..) ) 
    4949import Digraph          ( SCC(..) ) 
    5050import Bag 
    renameSigs :: HsSigCtxt 
    653653           -> RnM ([LSig Name], FreeVars) 
    654654-- Renames the signatures and performs error checks 
    655655renameSigs ctxt sigs  
    656   = do  { mapM_ dupSigDeclErr (findDupsEq overlapHsSig sigs)  -- Duplicate 
     656  = do  { mapM_ dupSigDeclErr (getDuplicateHsSigs sigs) 
    657657                -- Check for duplicates on RdrName version,  
    658658                -- because renamed version has unboundName for 
    659659                -- not-in-scope binders, which gives bogus dup-sig errors 
    rnGRHS' ctxt rnBody (GRHS guards rhs) 
    848848%************************************************************************ 
    849849 
    850850\begin{code} 
    851 dupSigDeclErr :: [LSig RdrName] -> RnM () 
    852 dupSigDeclErr sigs@(L loc sig : _) 
    853   = addErrAt loc $ 
    854         vcat [ptext (sLit "Duplicate") <+> what_it_is <> colon, 
    855               nest 2 (vcat (map ppr_sig sigs))] 
     851dupSigDeclErr :: (Either RdrName Var, [LSig RdrName]) -> RnM () 
     852dupSigDeclErr (eithername, sigs@(L loc sig : _)) 
     853  = addErrAt loc $ vcat 
     854      [ ptext (sLit "Duplicate") <+> whatItIs <+> 
     855        ptext (sLit "for") <+> pprEither eithername <> colon 
     856      , nest 2 (vcat (map pprSig sigs)) ] 
    856857  where 
    857     what_it_is = hsSigDoc sig 
    858     ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig 
    859 dupSigDeclErr [] = panic "dupSigDeclErr" 
     858    whatItIs = hsSigDoc sig 
     859    pprSig (L loc sig) = ppr loc <> colon <+> ppr sig 
     860    pprEither (Left n) = ppr n 
     861    pprEither (Right n) = ppr n 
     862dupSigDeclErr _ = panic "dupSigDeclErr" 
    860863 
    861864misplacedSigErr :: LSig Name -> RnM () 
    862865misplacedSigErr (L loc sig)