diff options
Diffstat (limited to 'compiler/GHC/Rename')
| -rw-r--r-- | compiler/GHC/Rename/Bind.hs | 13 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Env.hs | 71 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Fixity.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Rename/HsType.hs | 15 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Module.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Names.hs | 351 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Splice.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Unbound.hs | 20 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Utils.hs | 55 |
9 files changed, 331 insertions, 210 deletions
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 30fef1b980..ea76feea82 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -47,6 +47,7 @@ import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Driver.Session import GHC.Unit.Module +import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -692,13 +693,15 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name ; return ( (pat', InfixCon name1 name2) , mkFVs (map unLoc [name1, name2])) } RecCon vars -> - do { checkDupRdrNames (map recordPatSynSelectorId vars) + do { checkDupRdrNames (map (rdrNameFieldOcc . recordPatSynField) vars) + ; fls <- lookupConstructorFields name + ; let fld_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ] ; let rnRecordPatSynField - (RecordPatSynField { recordPatSynSelectorId = visible + (RecordPatSynField { recordPatSynField = visible , recordPatSynPatVar = hidden }) - = do { visible' <- lookupLocatedTopBndrRn visible + = do { let visible' = lookupField fld_env visible ; hidden' <- lookupPatSynBndr hidden - ; return $ RecordPatSynField { recordPatSynSelectorId = visible' + ; return $ RecordPatSynField { recordPatSynField = visible' , recordPatSynPatVar = hidden' } } ; names <- mapM rnRecordPatSynField vars ; return ( (pat', RecCon names) @@ -726,7 +729,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name , psb_ext = fvs' } selector_names = case details' of RecCon names -> - map (unLoc . recordPatSynSelectorId) names + map (extFieldOcc . recordPatSynField) names _ -> [] ; fvs' `seq` -- See Note [Free-variable space leak] diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 621a01cb6c..435c20c16e 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -267,7 +267,7 @@ lookupTopBndrRn rdr_name = ; env <- getGlobalRdrEnv ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of - [gre] -> return (gre_name gre) + [gre] -> return (greMangledName gre) _ -> do -- Ambiguous (can't happen) or unbound traceRn "lookupTopBndrRN fail" (ppr rdr_name) unboundName WL_LocalTop rdr_name @@ -307,9 +307,9 @@ lookupExactOcc_either name Nothing -> [] gres = [ gre | occ <- main_occ : demoted_occs , gre <- lookupGlobalRdrEnv env occ - , gre_name gre == name ] + , greMangledName gre == name ] ; case gres of - [gre] -> return (Right (gre_name gre)) + [gre] -> return (Right (greMangledName gre)) [] -> -- See Note [Splicing Exact names] do { lcl_env <- getLocalRdrEnv @@ -332,7 +332,7 @@ sameNameErr gres@(_ : _) = hang (text "Same exact name in multiple name-spaces:") 2 (vcat (map pp_one sorted_names) $$ th_hint) where - sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map gre_name gres) + sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map greMangledName gres) pp_one name = hang (pprNameSpace (occNameSpace (getOccName name)) <+> quotes (ppr name) <> comma) @@ -598,7 +598,7 @@ lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name | isUnboundName parent -- Avoid an error cascade - = return (FoundName NoParent (mkUnboundNameRdr rdr_name)) + = return (FoundChild NoParent (NormalGreName (mkUnboundNameRdr rdr_name))) | otherwise = do gre_env <- getGlobalRdrEnv @@ -624,20 +624,9 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name where -- Convert into FieldLabel if necessary checkFld :: GlobalRdrElt -> RnM ChildLookupResult - checkFld g@GRE{gre_name, gre_par} = do + checkFld g@GRE{gre_name,gre_par} = do addUsedGRE warn_if_deprec g - return $ case gre_par of - FldParent _ mfs -> - FoundFL (fldParentToFieldLabel gre_name mfs) - _ -> FoundName gre_par gre_name - - fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel - fldParentToFieldLabel name mfs = - case mfs of - Nothing -> - let fs = occNameFS (nameOccName name) - in FieldLabel fs False name - Just fs -> FieldLabel fs True name + return $ FoundChild gre_par gre_name -- Called when we find no matching GREs after disambiguation but -- there are three situations where this happens. @@ -655,27 +644,25 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name case original_gres of [] -> return NameNotFound [g] -> return $ IncorrectParent parent - (gre_name g) (ppr $ gre_name g) + (gre_name g) [p | Just p <- [getParent g]] gss@(g:_:_) -> if all isRecFldGRE gss && overload_ok then return $ IncorrectParent parent (gre_name g) - (ppr $ expectJust "noMatchingParentErr" (greLabel g)) [p | x <- gss, Just p <- [getParent x]] else mkNameClashErr gss mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult mkNameClashErr gres = do addNameClashErrRn rdr_name gres - return (FoundName (gre_par (head gres)) (gre_name (head gres))) + return (FoundChild (gre_par (head gres)) (gre_name (head gres))) getParent :: GlobalRdrElt -> Maybe Name getParent (GRE { gre_par = p } ) = case p of ParentIs cur_parent -> Just cur_parent - FldParent { par_is = cur_parent } -> Just cur_parent NoParent -> Nothing picked_gres :: [GlobalRdrElt] -> DisambigInfo @@ -743,11 +730,9 @@ instance Monoid DisambigInfo where data ChildLookupResult = NameNotFound -- We couldn't find a suitable name | IncorrectParent Name -- Parent - Name -- Name of thing we were looking for - SDoc -- How to print the name + GreName -- Child we were looking for [Name] -- List of possible parents - | FoundName Parent Name -- We resolved to a normal name - | FoundFL FieldLabel -- We resolved to a FL + | FoundChild Parent GreName -- We resolved to a child -- | Specialised version of msum for RnM ChildLookupResult combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult @@ -760,10 +745,9 @@ combineChildLookupResult (x:xs) = do instance Outputable ChildLookupResult where ppr NameNotFound = text "NameNotFound" - ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n - ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls - ppr (IncorrectParent p n td ns) = text "IncorrectParent" - <+> hsep [ppr p, ppr n, td, ppr ns] + ppr (FoundChild p n) = text "Found:" <+> ppr p <+> ppr n + ppr (IncorrectParent p n ns) = text "IncorrectParent" + <+> hsep [ppr p, ppr n, ppr ns] lookupSubBndrOcc :: Bool -> Name -- Parent @@ -774,13 +758,12 @@ lookupSubBndrOcc :: Bool -- and pick the one with the right parent namep lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do res <- - lookupExactOrOrig rdr_name (FoundName NoParent) $ + lookupExactOrOrig rdr_name (FoundChild NoParent . NormalGreName) $ -- This happens for built-in classes, see mod052 for example lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name case res of NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name)) - FoundName _p n -> return (Right n) - FoundFL fl -> return (Right (flSelector fl)) + FoundChild _p child -> return (Right (greNameMangledName child)) IncorrectParent {} -- See [Mismatched class methods and associated type families] -- in TcInstDecls. @@ -1137,7 +1120,7 @@ lookupGlobalOccRn rdr_name = lookupGlobalOccRn_base :: RdrName -> RnM (Maybe Name) lookupGlobalOccRn_base rdr_name = runMaybeT . msum . map MaybeT $ - [ fmap gre_name <$> lookupGreRn_maybe rdr_name + [ fmap greMangledName <$> lookupGreRn_maybe rdr_name , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ] -- This test is not expensive, -- and only happens for failed lookups @@ -1153,7 +1136,7 @@ lookupInfoOccRn :: RdrName -> RnM [Name] lookupInfoOccRn rdr_name = lookupExactOrOrig rdr_name (:[]) $ do { rdr_env <- getGlobalRdrEnv - ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env) + ; let ns = map greMangledName (lookupGRE_RdrName rdr_name rdr_env) ; qual_ns <- lookupQualifiedNameGHCi rdr_name ; return (ns ++ (qual_ns `minusList` ns)) } @@ -1176,14 +1159,14 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name = GreNotFound -> return Nothing OneNameMatch gre -> do let wrapper = if isRecFldGRE gre then Right . (:[]) else Left - return $ Just (wrapper (gre_name gre)) + return $ Just (wrapper (greMangledName gre)) MultipleNames gres | all isRecFldGRE gres && overload_ok -> -- Don't record usage for ambiguous selectors -- until we know which is meant - return $ Just (Right (map gre_name gres)) + return $ Just (Right (map greMangledName gres)) MultipleNames gres -> do addNameClashErrRn rdr_name gres - return (Just (Left (gre_name (head gres)))) } + return (Just (Left (greMangledName (head gres)))) } -------------------------------------------------- @@ -1270,7 +1253,7 @@ lookupGreAvailRn rdr_name -- Returning an unbound name here prevents an error -- cascade OneNameMatch gre -> - return (gre_name gre, availFromGRE gre) + return (greMangledName gre, availFromGRE gre) {- @@ -1327,7 +1310,7 @@ addUsedGREs gres imp_gres = filterOut isLocalGRE gres warnIfDeprecated :: GlobalRdrElt -> RnM () -warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) +warnIfDeprecated gre@(GRE { gre_imp = iss }) | (imp_spec : _) <- iss = do { dflags <- getDynFlags ; this_mod <- getModule @@ -1343,6 +1326,7 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) = return () where occ = greOccName gre + name = greMangledName gre name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly") @@ -1363,7 +1347,6 @@ lookupImpDeprec iface gre = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing, case gre_par gre of -- or its parent, is warn'd ParentIs p -> mi_warn_fn (mi_final_exts iface) (nameOccName p) - FldParent { par_is = p } -> mi_warn_fn (mi_final_exts iface) (nameOccName p) NoParent -> Nothing {- @@ -1575,14 +1558,14 @@ lookupBindGroupOcc ctxt what rdr_name filter (\n -> nameSpacesRelated (rdrNameSpace rdr_name) (nameNameSpace n)) - $ map gre_name + $ map greMangledName $ filter isLocalGRE $ globalRdrEnvElts env candidates_msg = candidates names_in_scope - ; case filter (keep_me . gre_name) all_gres of + ; case filter (keep_me . greMangledName) all_gres of [] | null all_gres -> bale_out_with candidates_msg | otherwise -> bale_out_with local_msg - (gre:_) -> return (Right (gre_name gre)) } + (gre:_) -> return (Right (greMangledName gre)) } lookup_group bound_names -- Look in the local envt (not top level) = do { mname <- lookupLocalOccRn_maybe rdr_name diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs index a66d9de5bf..9529e2b68e 100644 --- a/compiler/GHC/Rename/Fixity.hs +++ b/compiler/GHC/Rename/Fixity.hs @@ -211,7 +211,7 @@ lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr) ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs) >> return (Fixity NoSourceText minPrecedence InfixL) - lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre) + lookup_gre_fixity gre = lookupFixityRn' (greMangledName gre) (greOccName gre) ambiguous_fixity_err rn ambigs = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn) diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 34f2cf1ca2..b4498c80ee 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -17,6 +17,7 @@ module GHC.Rename.HsType ( HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, newTyVarNameRn, rnConDeclFields, + lookupField, rnLTyVar, rnScaledLHsType, @@ -1247,17 +1248,17 @@ rnConDeclFields ctxt fls fields rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs -> RnM (LConDeclField GhcRn, FreeVars) rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) - = do { let new_names = map (fmap lookupField) names + = do { let new_names = map (fmap (lookupField fl_env)) names ; (new_ty, fvs) <- rnLHsTyKi env ty ; return (L l (ConDeclField noExtField new_names new_ty haddock_doc) , fvs) } + +lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn +lookupField fl_env (FieldOcc _ (L lr rdr)) = + FieldOcc (flSelector fl) (L lr rdr) where - lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn - lookupField (FieldOcc _ (L lr rdr)) = - FieldOcc (flSelector fl) (L lr rdr) - where - lbl = occNameFS $ rdrNameOcc rdr - fl = expectJust "rnField" $ lookupFsEnv fl_env lbl + lbl = occNameFS $ rdrNameOcc rdr + fl = expectJust "lookupField" $ lookupFsEnv fl_env lbl {- ************************************************************************ diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index d47d652358..e098156d1d 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -1613,7 +1613,6 @@ getParent rdr_env n = case lookupGRE_Name rdr_env n of Just gre -> case gre_par gre of ParentIs { par_is = p } -> p - FldParent { par_is = p } -> p _ -> n Nothing -> n @@ -2389,7 +2388,8 @@ extendPatSynEnv val_decls local_fix_env thing = do { names_with_fls <- new_ps val_decls ; let pat_syn_bndrs = concat [ name: map flSelector fields | (name, fields) <- names_with_fls ] - ; let avails = map avail pat_syn_bndrs + ; let avails = map avail (map fst names_with_fls) + ++ map availField (concatMap snd names_with_fls) ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls @@ -2408,11 +2408,9 @@ extendPatSynEnv val_decls local_fix_env thing = do { , psb_args = RecCon as }))) <- bind = do bnd_name <- newTopSrcBinder (L bind_loc n) - let rnames = map recordPatSynSelectorId as - mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs - mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name)) - field_occs = map mkFieldOcc rnames - flds <- mapM (newRecordSelector False [bnd_name]) field_occs + let field_occs = map ((\ f -> L (getLoc (rdrNameFieldOcc f)) f) . recordPatSynField) as + overload_ok <- xoptM LangExt.DuplicateRecordFields + flds <- mapM (newRecordSelector overload_ok [bnd_name]) field_occs return ((bnd_name, flds): names) | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind = do diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 45b8bcd313..a52f7bca3c 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -84,7 +84,7 @@ import GHC.Data.FastString import GHC.Data.FastString.Env import Control.Monad -import Data.Either ( partitionEithers, isRight, rights ) +import Data.Either ( partitionEithers ) import Data.Map ( Map ) import qualified Data.Map as Map import Data.Ord ( comparing ) @@ -645,7 +645,7 @@ extendGlobalRdrEnvRn avails new_fixities | otherwise = fix_env where - name = gre_name gre + name = greMangledName gre occ = greOccName gre new_gres :: [GlobalRdrElt] -- New LocalDef GREs, derived from avails @@ -663,12 +663,70 @@ extendGlobalRdrEnvRn avails new_fixities | otherwise = return (extendGlobalRdrEnv env gre) where - occ = greOccName gre - dups = filter isDupGRE (lookupGlobalRdrEnv env occ) - -- Duplicate GREs are those defined locally with the same OccName, - -- except cases where *both* GREs are DuplicateRecordFields (#17965). + -- See Note [Reporting duplicate local declarations] + dups = filter isDupGRE (lookupGlobalRdrEnv env (greOccName gre)) isDupGRE gre' = isLocalGRE gre' - && not (isOverloadedRecFldGRE gre && isOverloadedRecFldGRE gre') + && (not (isOverloadedRecFldGRE gre && isOverloadedRecFldGRE gre') + || (gre_name gre == gre_name gre')) + +{- +Note [Reporting duplicate local declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, a single module may not define the same OccName multiple times. This +is checked in extendGlobalRdrEnvRn: when adding a new locally-defined GRE to the +GlobalRdrEnv we report an error if there are already duplicates in the +environment. This establishes INVARIANT 1 of the GlobalRdrEnv, which says that +for a given OccName, all the GlobalRdrElts to which it maps must have distinct +'gre_name's. + +For example, the following will be rejected: + + f x = x + g x = x + f x = x -- Duplicate! + +Under what conditions will a GRE that exists already count as a duplicate of the +LocalDef GRE being added? + +* It must also be a LocalDef: the programmer is allowed to make a new local + definition that clashes with an imported one (although attempting to refer to + either may lead to ambiguity errors at use sites). For example, the following + definition is allowed: + + import M (f) + f x = x + +* When DuplicateRecordFields is enabled, the same field label may be defined in + multiple records. For example, this is allowed: + + {-# LANGUAGE DuplicateRecordFields #-} + data S1 = MkS1 { f :: Int } + data S2 = MkS2 { f :: Int } + + Even though both fields have the same OccName, this does not violate INVARIANT + 1, because the fields have distinct selector names, which form part of the + gre_name (see Note [GreNames] in GHC.Types.Name.Reader). + +* However, we must be careful to reject the following (#9156): + + {-# LANGUAGE DuplicateRecordFields #-} + data T = MkT { f :: Int, f :: Int } -- Duplicate! + + In this case, both 'gre_name's are the same (because the fields belong to the + same type), and adding them both to the environment would be a violation of + INVARIANT 1. Thus isDupGRE checks whether both GREs have the same gre_name. + +* We also reject attempts to define a field and a non-field with the same + OccName (#17965): + + {-# LANGUAGE DuplicateRecordFields #-} + f x = x + data T = MkT { f :: Int} + + In principle this could be supported, but the current "specification" of + DuplicateRecordFields does not allow it. Thus isDupGRE checks that *both* GREs + being compared are record fields. +-} {- ********************************************************************* @@ -760,7 +818,7 @@ getLocalNonValBinders fixity_env ; let fld_env = case unLoc tc_decl of DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' _ -> [] - ; return (AvailTC main_name names flds', fld_env) } + ; return (availTC main_name names flds', fld_env) } -- Calculate the mapping from constructor names to fields, which @@ -835,7 +893,7 @@ getLocalNonValBinders fixity_env ; let (bndrs, flds) = hsDataFamInstBinders dfid ; sub_names <- mapM newTopSrcBinder bndrs ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds - ; let avail = AvailTC (unLoc main_name) sub_names flds' + ; let avail = availTC (unLoc main_name) sub_names flds' -- main_name is not bound here! fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' ; return (avail, fld_env) } @@ -848,10 +906,12 @@ newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld))) = do { selName <- newTopSrcBinder $ L loc $ field - ; return $ qualFieldLbl { flSelector = selName } } + ; return $ FieldLabel { flLabel = fieldLabelString + , flIsOverloaded = overload_ok + , flSelector = selName } } where - fieldOccName = occNameFS $ rdrNameOcc fld - qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok + fieldLabelString = occNameFS $ rdrNameOcc fld + selOccName = fieldSelectorOccName fieldLabelString (nameOccName dc) overload_ok field | isExact fld = fld -- use an Exact RdrName as is to preserve the bindings -- of an already renamer-resolved field and its use @@ -859,7 +919,7 @@ newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld))) -- selectors in Template Haskell. See Note [Binders in -- Template Haskell] in "GHC.ThToHs" and Note [Looking up -- Exact RdrNames] in "GHC.Rename.Env". - | otherwise = mkRdrUnqual (flSelector qualFieldLbl) + | otherwise = mkRdrUnqual selOccName {- Note [Looking up family names in family instances] @@ -892,9 +952,12 @@ available, and filters it through the import spec (if any). Note [Dealing with imports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ For import M( ies ), we take the mi_exports of M, and make - imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name) -One entry for each Name that M exports; the AvailInfo is the -AvailInfo exported from M that exports that Name. + imp_occ_env :: OccEnv (NameEnv (GreName, AvailInfo, Maybe Name)) +One entry for each OccName that M exports, mapping each corresponding Name to +its GreName, the AvailInfo exported from M that exports that Name, and +optionally a Name for an associated type's parent class. (Typically there will +be a single Name in the NameEnv, but see Note [Importing DuplicateRecordFields] +for why we may need more than one.) The situation is made more complicated by associated types. E.g. module M where @@ -906,7 +969,7 @@ Then M's export_avails are (recall the AvailTC invariant from Avails.hs) Notice that T appears *twice*, once as a child and once as a parent. From this list we construct a raw list including T -> (T, T( T1, T2, T3 ), Nothing) - T -> (C, C( C, T ), Nothing) + T -> (T, C( C, T ), Nothing) and we combine these (in function 'combine' in 'imp_occ_env' in 'filterImports') to get T -> (T, T(T,T1,T2,T3), Just C) @@ -922,6 +985,57 @@ then we get *two* Avails: C(T), T(T1,T2) Note that the imp_occ_env will have entries for data constructors too, although we never look up data constructors. + +Note [Importing PatternSynonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Dealing with imports], associated types can lead to the +same Name appearing twice, both as a child and once as a parent, when +constructing the imp_occ_env. The same thing can happen with pattern synonyms +if they are exported bundled with a type. + +A simplified example, based on #11959: + + {-# LANGUAGE PatternSynonyms #-} + module M (T(P), pattern P) where -- Duplicate export warning, but allowed + data T = MkT + pattern P = MkT + +Here we have T(P) and P in export_avails, and construct both + P -> (P, P, Nothing) + P -> (P, T(P), Nothing) +which are 'combine'd to leave + P -> (P, T(P), Nothing) +i.e. we simply discard the non-bundled Avail. + +Note [Importing DuplicateRecordFields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In filterImports, another complicating factor is DuplicateRecordFields. +Suppose we have: + + {-# LANGUAGE DuplicateRecordFields #-} + module M (S(foo), T(foo)) where + data S = MkS { foo :: Int } + data T = mkT { foo :: Int } + + module N where + import M (foo) -- this is an ambiguity error (A) + import M (S(foo)) -- this is allowed (B) + +Here M exports the OccName 'foo' twice, so we get an imp_occ_env where 'foo' +maps to a NameEnv containing an entry for each of the two mangled field selector +names (see Note [FieldLabel] in GHC.Types.FieldLabel). + + foo -> [ $sel:foo:MkS -> (foo, S(foo), Nothing) + , $sel:foo:MKT -> (foo, T(foo), Nothing) + ] + +Then when we look up 'foo' in lookup_name for case (A) we get both entries and +hence report an ambiguity error. Whereas in case (B) we reach the lookup_ie +case for IEThingWith, which looks up 'S' and then finds the unique 'foo' amongst +its children. + +See T16745 for a test of this. + -} filterImports @@ -958,30 +1072,46 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) all_avails = mi_exports iface -- See Note [Dealing with imports] - imp_occ_env :: OccEnv (Name, -- the name - AvailInfo, -- the export item providing the name - Maybe Name) -- the parent of associated types - imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing)) + imp_occ_env :: OccEnv (NameEnv (GreName, -- the name or field + AvailInfo, -- the export item providing it + Maybe Name)) -- the parent of associated types + imp_occ_env = mkOccEnv_C (plusNameEnv_C combine) + [ (occName c, mkNameEnv [(greNameMangledName c, (c, a, Nothing))]) | a <- all_avails - , (n, occ) <- availNamesWithOccs a] - where - -- See Note [Dealing with imports] - -- 'combine' is only called for associated data types which appear - -- twice in the all_avails. In the example, we combine - -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) - -- NB: the AvailTC can have fields as well as data constructors (#12127) - combine (name1, a1@(AvailTC p1 _ _), mp1) - (name2, a2@(AvailTC p2 _ _), mp2) - = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2 - , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 ) - if p1 == name1 then (name1, a1, Just p2) - else (name1, a2, Just p1) - combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) + , c <- availGreNames a] + -- See Note [Dealing with imports] + -- 'combine' may be called for associated data types which appear + -- twice in the all_avails. In the example, we combine + -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) + -- NB: the AvailTC can have fields as well as data constructors (#12127) + combine :: (GreName, AvailInfo, Maybe Name) + -> (GreName, AvailInfo, Maybe Name) + -> (GreName, AvailInfo, Maybe Name) + combine (NormalGreName name1, a1@(AvailTC p1 _), mb1) + (NormalGreName name2, a2@(AvailTC p2 _), mb2) + = ASSERT2( name1 == name2 && isNothing mb1 && isNothing mb2 + , ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2 ) + if p1 == name1 then (NormalGreName name1, a1, Just p2) + else (NormalGreName name1, a2, Just p1) + -- 'combine' may also be called for pattern synonyms which appear both + -- unassociated and associated (see Note [Importing PatternSynonyms]). + combine (c1, a1, mb1) (c2, a2, mb2) + = ASSERT2( c1 == c2 && isNothing mb1 && isNothing mb2 + && (isAvailTC a1 || isAvailTC a2) + , ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2 ) + if isAvailTC a1 then (c1, a1, Nothing) + else (c1, a2, Nothing) + + isAvailTC AvailTC{} = True + isAvailTC _ = False lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name) lookup_name ie rdr | isQual rdr = failLookupWith (QualImportError rdr) - | Just succ <- mb_success = return succ + | Just succ <- mb_success = case nameEnvElts succ of + -- See Note [Importing DuplicateRecordFields] + [(c,a,x)] -> return (greNameMangledName c, a, x) + xs -> failLookupWith (AmbiguousImport rdr (map sndOf3 xs)) | otherwise = failLookupWith (BadImport ie) where mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) @@ -1011,6 +1141,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) BadImport ie -> badImportItemErr iface decl_spec ie all_avails IllegalImport -> illegalImportItemErr QualImportError rdr -> qualImportItemErr rdr + AmbiguousImport rdr xs -> ambiguousImportItemErr rdr xs -- For each import item, we convert its RdrNames to Names, -- and at the same time construct an AvailInfo corresponding @@ -1037,8 +1168,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) Avail {} -- e.g. f(..) -> [DodgyImport $ ieWrappedName tc] - AvailTC _ subs fs - | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym + AvailTC _ subs + | null (drop 1 subs) -- e.g. T(..) where T is a synonym -> [DodgyImport $ ieWrappedName tc] | not (is_qual decl_spec) -- e.g. import M( T(..) ) @@ -1049,12 +1180,12 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) renamed_ie = IEThingAll noExtField (L l (replaceWrappedName tc name)) sub_avails = case avail of - Avail {} -> [] - AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)] + Avail {} -> [] + AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [NormalGreName name]))] case mb_parent of Nothing -> return ([(renamed_ie, avail)], warns) -- non-associated ty/cls - Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns) + Just parent -> return ((renamed_ie, AvailTC parent [NormalGreName name]) : sub_avails, warns) -- associated type IEThingAbs _ (L l tc') @@ -1073,25 +1204,16 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) return ([mkIEThingAbs tc' l nameAvail] , []) - IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs -> - ASSERT2(null rdr_fs, ppr rdr_fs) do + IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns -> do (name, avail, mb_parent) <- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc) - let (ns,subflds) = case avail of - AvailTC _ ns' subflds' -> (ns',subflds') - Avail _ -> panic "filterImports" - -- Look up the children in the sub-names of the parent - let subnames = case ns of -- The tc is first in ns, - [] -> [] -- if it is there at all - -- See the AvailTC Invariant in - -- GHC.Types.Avail - (n1:ns1) | n1 == name -> ns1 - | otherwise -> ns - case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of - - Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs [])) + -- See Note [Importing DuplicateRecordFields] + let subnames = availSubordinateGreNames avail + case lookupChildren subnames rdr_ns of + + Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs)) -- We are trying to import T( a,b,c,d ), and failed -- to find 'b' and 'd'. So we make up an import item -- to report as failing, namely T( b, d ). @@ -1101,21 +1223,18 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) case mb_parent of -- non-associated ty/cls Nothing - -> return ([(IEThingWith noExtField (L l name') wc childnames' - childflds, - AvailTC name (name:map unLoc childnames) (map unLoc childflds))], + -> return ([(IEThingWith childflds (L l name') wc childnames', + availTC name (name:map unLoc childnames) (map unLoc childflds))], []) where name' = replaceWrappedName rdr_tc name childnames' = map to_ie_post_rn childnames -- childnames' = postrn_ies childnames -- associated ty Just parent - -> return ([(IEThingWith noExtField (L l name') wc childnames' - childflds, - AvailTC name (map unLoc childnames) (map unLoc childflds)), - (IEThingWith noExtField (L l name') wc childnames' - childflds, - AvailTC parent [name] [])], + -> return ([(IEThingWith childflds (L l name') wc childnames', + availTC name (map unLoc childnames) (map unLoc childflds)), + (IEThingWith childflds (L l name') wc childnames', + availTC parent [name] [])], []) where name' = replaceWrappedName rdr_tc name childnames' = map to_ie_post_rn childnames @@ -1129,7 +1248,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) = (IEThingAbs noExtField (L l (replaceWrappedName tc n)), trimAvail av n) mkIEThingAbs tc l (n, _, Just parent) = (IEThingAbs noExtField (L l (replaceWrappedName tc n)) - , AvailTC parent [n] []) + , availTC parent [n] []) handle_bad_import m = catchIELookup m $ \err -> case err of BadImport ie | want_hiding -> return ([], [BadImportW ie]) @@ -1147,6 +1266,7 @@ data IELookupError = QualImportError RdrName | BadImport (IE GhcPs) | IllegalImport + | AmbiguousImport RdrName [AvailInfo] -- e.g. a duplicated field name as a top-level import failLookupWith :: IELookupError -> IELookupM a failLookupWith err = Failed err @@ -1201,14 +1321,13 @@ mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] mkChildEnv gres = foldr add emptyNameEnv gres where add gre env = case gre_par gre of - FldParent p _ -> extendNameEnv_Acc (:) Utils.singleton env p gre ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre NoParent -> env findChildren :: NameEnv [a] -> Name -> [a] findChildren env n = lookupNameEnv env n `orElse` [] -lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName] +lookupChildren :: [GreName] -> [LIEWrappedName RdrName] -> MaybeErr [LIEWrappedName RdrName] -- The ones for which the lookup failed ([Located Name], [Located FieldLabel]) -- (lookupChildren all_kids rdr_items) maps each rdr_item to its @@ -1233,13 +1352,13 @@ lookupChildren all_kids rdr_items doOne item@(L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of - Just [Left n] -> Succeeded (Left (L l n)) - Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs))) - _ -> Failed item + Just [NormalGreName n] -> Succeeded (Left (L l n)) + Just rs | Just fs <- traverse greNameFieldLabel rs -> Succeeded (Right (map (L l) fs)) + _ -> Failed item -- See Note [Children for duplicate record fields] kid_env = extendFsEnvList_C (++) emptyFsEnv - [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids] + [(occNameFS (occName x), [x]) | x <- all_kids] @@ -1274,11 +1393,13 @@ reportUnusedNames gbl_env hsc_src -- This is done in mkExports too; duplicated work gre_is_used :: NameSet -> GlobalRdrElt -> Bool - gre_is_used used_names (GRE {gre_name = name}) + gre_is_used used_names gre0 = name `elemNameSet` used_names - || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name) + || any (\ gre -> greMangledName gre `elemNameSet` used_names) (findChildren kids_env name) -- A use of C implies a use of T, -- if C was brought into scope by T(..) or T(C) + where + name = greMangledName gre0 -- Filter out the ones that are -- (a) defined in this module, and @@ -1295,7 +1416,7 @@ reportUnusedNames gbl_env hsc_src in filter is_unused_local defined_but_not_used is_unused_local :: GlobalRdrElt -> Bool - is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre) + is_unused_local gre = isLocalGRE gre && isExternalName (greMangledName gre) {- ********************************************************************* * * @@ -1422,7 +1543,7 @@ findImportUsage imports used_gres -- srcSpanEnd: see Note [The ImportMap] `orElse` [] - used_names = mkNameSet (map gre_name used_gres) + used_names = mkNameSet (map greMangledName used_gres) used_parents = mkNameSet (mapMaybe greParent_maybe used_gres) unused_imps -- Not trivial; see eg #7454 @@ -1435,7 +1556,7 @@ findImportUsage imports used_gres add_unused (IEVar _ n) acc = add_unused_name (lieWrappedName n) acc add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc add_unused (IEThingAll _ n) acc = add_unused_all (lieWrappedName n) acc - add_unused (IEThingWith _ p wc ns fs) acc = + add_unused (IEThingWith fs p wc ns) acc = add_wc_all (add_unused_with pn xs acc) where pn = lieWrappedName p xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs @@ -1501,7 +1622,7 @@ mkImportMap gres best_imp_spec = bestImport imp_specs add _ gres = gre : gres -warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name) +warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Parent) -> ImportDeclUsage -> RnM () warnUnusedImport flag fld_env (L loc decl, used, unused) @@ -1553,8 +1674,9 @@ warnUnusedImport flag fld_env (L loc decl, used, unused) -- to improve the consistent for ambiguous/unambiguous identifiers. -- See trac#14881. ppr_possible_field n = case lookupNameEnv fld_env n of - Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld) - Nothing -> pprNameUnqualified n + Just (fld, ParentIs p) -> pprNameUnqualified p <> parens (ppr fld) + Just (fld, NoParent) -> ppr fld + Nothing -> pprNameUnqualified n -- Print unused names in a deterministic (lexicographic) order sort_unused :: SDoc @@ -1606,35 +1728,30 @@ getMinimalImports = fmap combine . mapM mk_minimal -- The main trick here is that if we're importing all the constructors -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. - to_ie _ (Avail n) - = [IEVar noExtField (to_ie_post_rn $ noLoc n)] - to_ie _ (AvailTC n [m] []) - | n==m = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)] - to_ie iface (AvailTC n ns fs) - = case [(xs,gs) | AvailTC x xs gs <- mi_exports iface + to_ie _ (Avail c) -- Note [Overloaded field import] + = [IEVar noExtField (to_ie_post_rn $ noLoc (greNamePrintableName c))] + to_ie _ avail@(AvailTC n [_]) -- Exporting the main decl and nothing else + | availExportsDecl avail = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)] + to_ie iface (AvailTC n cs) + = case [xs | avail@(AvailTC x xs) <- mi_exports iface , x == n - , x `elem` xs -- Note [Partial export] + , availExportsDecl avail -- Note [Partial export] ] of [xs] | all_used xs -> [IEThingAll noExtField (to_ie_post_rn $ noLoc n)] | otherwise -> - [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard - (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) - (map noLoc fs)] + [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLoc n) NoIEWildcard + (map (to_ie_post_rn . noLoc) (filter (/= n) ns))] -- Note [Overloaded field import] _other | all_non_overloaded fs -> map (IEVar noExtField . to_ie_post_rn_var . noLoc) $ ns ++ map flSelector fs | otherwise -> - [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard - (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) - (map noLoc fs)] + [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLoc n) NoIEWildcard + (map (to_ie_post_rn . noLoc) (filter (/= n) ns))] where + (ns, fs) = partitionGreNames cs - fld_lbls = map flLabel fs - - all_used (avail_occs, avail_flds) - = all (`elem` ns) avail_occs - && all (`elem` fld_lbls) (map flLabel avail_flds) + all_used avail_cs = all (`elem` cs) avail_cs all_non_overloaded = all (not . flIsOverloaded) @@ -1713,7 +1830,7 @@ Then the minimal import for module B is not import A( C( op ) ) which we would usually generate if C was exported from B. Hence -the (x `elem` xs) test when deciding what to generate. +the availExportsDecl test when deciding what to generate. Note [Overloaded field import] @@ -1733,6 +1850,23 @@ then the minimal import for module B must be because when DuplicateRecordFields is enabled, field selectors are not in scope without their enclosing datatype. +On the third hand, if we have + + {-# LANGUAGE DuplicateRecordFields #-} + module A where + pattern MkT { foo } = Just foo + + module B where + import A + f = ...foo... + +then the minimal import for module B must be + import A ( foo ) +because foo doesn't have a parent. This might actually be ambiguous if A +exports another field called foo, but there is no good answer to return and this +is a very obscure corner, so it seems to be the best we can do. See +DRFPatSynExport for a test of this. + ************************************************************************ * * @@ -1746,6 +1880,14 @@ qualImportItemErr rdr = hang (text "Illegal qualified name in import item:") 2 (ppr rdr) +ambiguousImportItemErr :: RdrName -> [AvailInfo] -> SDoc +ambiguousImportItemErr rdr avails + = hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:") + 2 (vcat (map ppr_avail avails)) + where + ppr_avail (AvailTC parent _) = ppr parent <> parens (ppr rdr) + ppr_avail (Avail name) = ppr name + pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc pprImpDeclSpec iface decl_spec = quotes (ppr (is_mod decl_spec)) <+> case mi_boot iface of @@ -1787,13 +1929,12 @@ badImportItemErr iface decl_spec ie avails Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie Nothing -> badImportItemErrStd iface decl_spec ie where - checkIfDataCon (AvailTC _ ns _) = - case find (\n -> importedFS == nameOccNameFS n) ns of - Just n -> isDataConName n + checkIfDataCon (AvailTC _ ns) = + case find (\n -> importedFS == occNameFS (occName n)) ns of + Just n -> isDataConName (greNameMangledName n) Nothing -> False checkIfDataCon _ = False - availOccName = nameOccName . availName - nameOccNameFS = occNameFS . nameOccName + availOccName = occName . availGreName importedFS = occNameFS . rdrNameOcc $ ieName ie illegalImportItemErr :: SDoc @@ -1834,7 +1975,7 @@ addDupDeclErr gres@(gre : _) where sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) - (map gre_name gres) + (map greMangledName gres) diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 48378ba670..19d9d333ec 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -433,7 +433,7 @@ rnSpliceExpr splice traceRn "rnSpliceExpr: typed expression splice" empty ; lcl_rdr <- getLocalRdrEnv ; gbl_rdr <- getGlobalRdrEnv - ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr + ; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr , isLocalGRE gre] lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index 4147b9517f..4422732363 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -180,8 +180,7 @@ similarNameSuggestions where_look dflags global_env | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) | gre <- globalRdrEnvElts global_env , isGreOk where_look gre - , let name = gre_name gre - occ = nameOccName name + , let occ = greOccName gre , correct_name_space occ , (mod, how) <- qualsInScope gre , let rdr_qual = mkRdrQual mod occ ] @@ -189,8 +188,7 @@ similarNameSuggestions where_look dflags global_env | otherwise = [ (rdr_unqual, pair) | gre <- globalRdrEnvElts global_env , isGreOk where_look gre - , let name = gre_name gre - occ = nameOccName name + , let occ = greOccName gre rdr_unqual = mkRdrUnqual occ , correct_name_space occ , pair <- case (unquals_in_scope gre, quals_only gre) of @@ -210,8 +208,8 @@ similarNameSuggestions where_look dflags global_env -------------------- unquals_in_scope :: GlobalRdrElt -> [HowInScope] - unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }) - | lcl = [ Left (nameSrcSpan n) ] + unquals_in_scope (gre@GRE { gre_lcl = lcl, gre_imp = is }) + | lcl = [ Left (greDefinitionSrcSpan gre) ] | otherwise = [ Right ispec | i <- is, let ispec = is_decl i , not (is_qual ispec) ] @@ -220,8 +218,8 @@ similarNameSuggestions where_look dflags global_env -------------------- quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)] -- Ones for which *only* the qualified version is in scope - quals_only (GRE { gre_name = n, gre_imp = is }) - = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec) + quals_only (gre@GRE { gre_imp = is }) + = [ (mkRdrQual (is_as ispec) (greOccName gre), Right ispec) | i <- is, let ispec = is_decl i, is_qual ispec ] -- | Generate helpful suggestions if a qualified name Mod.foo is not in scope. @@ -366,10 +364,10 @@ extensionSuggestions rdrName qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)] -- Ones for which the qualified version is in scope -qualsInScope GRE { gre_name = n, gre_lcl = lcl, gre_imp = is } - | lcl = case nameModule_maybe n of +qualsInScope gre@GRE { gre_lcl = lcl, gre_imp = is } + | lcl = case greDefinitionModule gre of Nothing -> [] - Just m -> [(moduleName m, Left (nameSrcSpan n))] + Just m -> [(moduleName m, Left (greDefinitionSrcSpan gre))] | otherwise = [ (is_as ispec, Right ispec) | i <- is, let ispec = is_decl i ] diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 3acf9d83d2..3a9fd56833 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -423,30 +423,26 @@ check_unused flag bound_names used_names warnUnusedGREs :: [GlobalRdrElt] -> RnM () warnUnusedGREs gres = mapM_ warnUnusedGRE gres +-- NB the Names must not be the names of record fields! warnUnused :: WarningFlag -> [Name] -> RnM () -warnUnused flag names = do - fld_env <- mkFieldEnv <$> getGlobalRdrEnv - mapM_ (warnUnused1 flag fld_env) names +warnUnused flag names = + mapM_ (warnUnused1 flag . NormalGreName) names -warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM () -warnUnused1 flag fld_env name - = when (reportable name occ) $ +warnUnused1 :: WarningFlag -> GreName -> RnM () +warnUnused1 flag child + = when (reportable child) $ addUnusedWarning flag - occ (nameSrcSpan name) + (occName child) (greNameSrcSpan child) (text $ "Defined but not used" ++ opt_str) where - occ = case lookupNameEnv fld_env name of - Just (fl, _) -> mkVarOccFS fl - Nothing -> nameOccName name opt_str = case flag of Opt_WarnUnusedTypePatterns -> " on the right hand side" _ -> "" warnUnusedGRE :: GlobalRdrElt -> RnM () -warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) - | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv - warnUnused1 Opt_WarnUnusedTopBinds fld_env name - | otherwise = when (reportable name occ) (mapM_ warn is) +warnUnusedGRE gre@(GRE { gre_lcl = lcl, gre_imp = is }) + | lcl = warnUnused1 Opt_WarnUnusedTopBinds (gre_name gre) + | otherwise = when (reportable (gre_name gre)) (mapM_ warn is) where occ = greOccName gre warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg @@ -457,22 +453,23 @@ warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) -- | Make a map from selector names to field labels and parent tycon -- names, to be used when reporting unused record fields. -mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name) -mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre))) +mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Parent) +mkFieldEnv rdr_env = mkNameEnv [ (greMangledName gre, (flLabel fl, gre_par gre)) | gres <- occEnvElts rdr_env , gre <- gres - , Just lbl <- [greLabel gre] + , Just fl <- [greFieldLabel gre] ] -- | Should we report the fact that this 'Name' is unused? The -- 'OccName' may differ from 'nameOccName' due to -- DuplicateRecordFields. -reportable :: Name -> OccName -> Bool -reportable name occ - | isWiredInName name = False -- Don't report unused wired-in names +reportable :: GreName -> Bool +reportable child + | NormalGreName name <- child + , isWiredInName name = False -- Don't report unused wired-in names -- Otherwise we get a zillion warnings -- from Data.Tuple - | otherwise = not (startsWithUnderscore occ) + | otherwise = not (startsWithUnderscore (occName child)) addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () addUnusedWarning flag occ span msg @@ -508,7 +505,7 @@ addNameClashErrRn rdr_name gres (np1:nps) = gres msg1 = text "either" <+> ppr_gre np1 msgs = [text " or" <+> ppr_gre np | np <- nps] - ppr_gre gre = sep [ pp_gre_name gre <> comma + ppr_gre gre = sep [ pp_greMangledName gre <> comma , pprNameProvenance gre] -- When printing the name, take care to qualify it in the same @@ -519,14 +516,14 @@ addNameClashErrRn rdr_name gres -- imported from ‘Prelude’ at T15487.hs:1:8-13 -- or ... -- See #15487 - pp_gre_name gre@(GRE { gre_name = name, gre_par = parent - , gre_lcl = lcl, gre_imp = iss }) - | FldParent { par_lbl = Just lbl } <- parent - = text "the field" <+> quotes (ppr lbl) - | otherwise - = quotes (pp_qual <> dot <> ppr (nameOccName name)) + pp_greMangledName gre@(GRE { gre_name = child + , gre_lcl = lcl, gre_imp = iss }) = + case child of + FieldGreName fl -> text "the field" <+> quotes (ppr fl) + NormalGreName name -> quotes (pp_qual name <> dot <> ppr (nameOccName name)) where - pp_qual | lcl + pp_qual name + | lcl = ppr (nameModule name) | imp : _ <- iss -- This 'imp' is the one that -- pprNameProvenance chooses |