[Git][ghc/ghc][master] Refactor lookupExactOrOrig & friends
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Jun 1 14:57:19 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
8e81f140 by sheaf at 2023-06-01T10:56:51-04:00
Refactor lookupExactOrOrig & friends
This refactors the panoply of renamer lookup functions relating to
lookupExactOrOrig to more graciously handle Exact and Orig names.
In particular, we avoid the situation in which we would add Exact/Orig
GREs to the tcg_used_gres field, which could cause a panic in bestImport
like in #23240.
Fixes #23428
- - - - -
13 changed files:
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Types/TyThing.hs
Changes:
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -331,26 +331,26 @@ lookupExactOcc_either name
-- 'RuntimeRep's (#17837)
UnboxedTuple -> tyConArity tycon `div` 2
_ -> tyConArity tycon
+ ; let info = case thing of
+ ATyCon {} -> IAmTyCon $ TupleFlavour $ tupleSortBoxity tupleSort
+ _ -> IAmConLike $ mkConInfo tupArity []
; checkTupSize tupArity
- ; let gre = (localTyConGRE (TupleFlavour $ tupleSortBoxity tupleSort) name)
- { gre_lcl = False }
- ; return (Right gre) }
+ ; return $ Right $ mkExactGRE name info }
| isExternalName name
- = Right <$> lookupExternalExactGRE name
+ = do { info <- lookupExternalExactName name
+ ; return $ Right $ mkExactGRE name info }
| otherwise
= lookupLocalExactGRE name
-lookupExternalExactGRE :: Name -> RnM GlobalRdrElt
-lookupExternalExactGRE name
+lookupExternalExactName :: Name -> RnM GREInfo
+lookupExternalExactName name
= do { thing <-
case wiredInNameTyThing_maybe name of
Just thing -> return thing
_ -> tcLookupGlobal name
- ; return $
- (localVanillaGRE NoParent name)
- { gre_lcl = False, gre_info = tyThingGREInfo thing } }
+ ; return $ tyThingGREInfo thing }
lookupLocalExactGRE :: Name -> RnM (Either NotInScopeError GlobalRdrElt)
lookupLocalExactGRE name
@@ -370,7 +370,7 @@ lookupLocalExactGRE name
[] -> -- See Note [Splicing Exact names]
do { lcl_env <- getLocalRdrEnv
- ; let gre = localVanillaGRE NoParent name -- LocalRdrEnv only contains Vanilla things
+ ; let gre = mkLocalVanillaGRE NoParent name -- LocalRdrEnv only contains Vanilla things
; if name `inLocalRdrEnvScope` lcl_env
then return (Right gre)
else
@@ -451,7 +451,7 @@ lookupExactOrOrig :: RdrName -> (GlobalRdrElt -> r) -> RnM r -> RnM r
lookupExactOrOrig rdr_name res k
= do { men <- lookupExactOrOrig_base rdr_name
; case men of
- FoundExactOrOrig n -> return $ res n
+ FoundExactOrOrig gre -> return $ res gre
ExactOrOrigError e ->
do { addErr (mkTcRnNotInScope rdr_name e)
; return $ res (mkUnboundGRERdr rdr_name) }
@@ -464,9 +464,9 @@ lookupExactOrOrig_maybe :: RdrName -> (Maybe GlobalRdrElt -> r) -> RnM r -> RnM
lookupExactOrOrig_maybe rdr_name res k
= do { men <- lookupExactOrOrig_base rdr_name
; case men of
- FoundExactOrOrig n -> return (res (Just n))
- ExactOrOrigError _ -> return (res Nothing)
- NotExactOrOrig -> k }
+ FoundExactOrOrig gre -> return (res (Just gre))
+ ExactOrOrigError _ -> return (res Nothing)
+ NotExactOrOrig -> k }
data ExactOrOrigResult
= FoundExactOrOrig GlobalRdrElt
@@ -490,15 +490,15 @@ lookupExactOrOrig_base rdr_name
; mb_gre <-
if nameIsLocalOrFrom this_mod nm
then lookupLocalExactGRE nm
- else Right <$> lookupExternalExactGRE nm
+ else do { info <- lookupExternalExactName nm
+ ; return $ Right $ mkExactGRE nm info }
; return $ case mb_gre of
Left err -> ExactOrOrigError err
Right gre -> FoundExactOrOrig gre }
| otherwise = return NotExactOrOrig
where
- cvtEither (Left e) = ExactOrOrigError e
- cvtEither (Right n) = FoundExactOrOrig n
-
+ cvtEither (Left e) = ExactOrOrigError e
+ cvtEither (Right gre) = FoundExactOrOrig gre
{- Note [Errors in lookup functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -561,7 +561,7 @@ lookupRecFieldOcc mb_con rdr_name
; Just nm -> return nm } }
| otherwise -- Can't use the data constructor to disambiguate
- = greName <$> lookupGlobalOccRn' (IncludeFields WantField) rdr_name
+ = lookupGlobalOccRn' (IncludeFields WantField) rdr_name
-- This use of Global is right as we are looking up a selector,
-- which can only be defined at the top level.
@@ -851,18 +851,16 @@ lookupSubBndrOcc :: DeprecationWarnings
-> RnM (Either NotInScopeError Name)
-- Find all the things the rdr-name maps to
-- and pick the one with the right parent name
-lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do
- res <-
- lookupExactOrOrig rdr_name FoundChild $
- -- 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 (UnknownSubordinate doc))
- FoundChild child -> return (Right $ greName child)
- IncorrectParent {}
- -- See [Mismatched class methods and associated type families]
- -- in TcInstDecls.
- -> return $ Left (UnknownSubordinate doc)
+lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name =
+ lookupExactOrOrig rdr_name (Right . greName) $
+ -- This happens for built-in classes, see mod052 for example
+ do { child <- lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name
+ ; return $ case child of
+ FoundChild g -> Right (greName g)
+ NameNotFound -> Left (UnknownSubordinate doc)
+ IncorrectParent {} -> Left (UnknownSubordinate doc) }
+ -- See [Mismatched class methods and associated type families]
+ -- in TcInstDecls.
{-
Note [Family instance binders]
@@ -1107,10 +1105,10 @@ lookup_demoted rdr_name
; let is_star_type = if star_is_type then StarIsType else StarIsNotType
star_is_type_hints = noStarIsTypeHints is_star_type rdr_name
; if data_kinds
- then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr
- ; case mb_demoted_name of
+ then do { mb_demoted_gre <- lookupOccRn_maybe demoted_rdr
+ ; case mb_demoted_gre of
Nothing -> unboundNameX looking_for rdr_name star_is_type_hints
- Just demoted_name -> return $ greName demoted_name }
+ Just demoted_gre -> return $ greName demoted_gre}
else do { -- We need to check if a data constructor of this name is
-- in scope to give good error messages. However, we do
-- not want to give an additional error if the data
@@ -1242,18 +1240,26 @@ lookupOccRnX_maybe globalLookup wrapper rdr_name
; case res of
{ Nothing -> return Nothing
; Just nm ->
- do { let gre = localVanillaGRE NoParent nm
+ -- Elements in the LocalRdrEnv are always Vanilla GREs
+ do { let gre = mkLocalVanillaGRE NoParent nm
; Just <$> wrapper gre } } }
, globalLookup rdr_name ]
lookupOccRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
lookupOccRn_maybe =
- lookupOccRnX_maybe (lookupGlobalOccRn_maybe $ IncludeFields WantNormal) return
+ lookupOccRnX_maybe
+ (lookupGlobalOccRn_maybe $ IncludeFields WantNormal)
+ return
-- Used outside this module only by TH name reification (lookupName, lookupThName_maybe)
-lookupSameOccRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
+lookupSameOccRn_maybe :: RdrName -> RnM (Maybe Name)
lookupSameOccRn_maybe =
- lookupOccRnX_maybe (lookupGlobalOccRn_maybe SameOccName) return
+ lookupOccRnX_maybe
+ (get_name <$> lookupGlobalOccRn_maybe SameOccName)
+ (return . greName)
+ where
+ get_name :: RnM (Maybe GlobalRdrElt) -> RnM (Maybe Name)
+ get_name = fmap (fmap greName)
-- | Look up a 'RdrName' used as a variable in an expression.
--
@@ -1292,7 +1298,7 @@ lookupGlobalOccRn_maybe which_gres rdr_name =
lookupExactOrOrig_maybe rdr_name id $
lookupGlobalOccRn_base which_gres rdr_name
-lookupGlobalOccRn :: RdrName -> RnM GlobalRdrElt
+lookupGlobalOccRn :: RdrName -> RnM Name
-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
-- environment. Adds an error message if the RdrName is not in scope.
-- You usually want to use "lookupOccRn" which also looks in the local
@@ -1301,15 +1307,14 @@ lookupGlobalOccRn :: RdrName -> RnM GlobalRdrElt
-- Used by exports_from_avail
lookupGlobalOccRn = lookupGlobalOccRn' (IncludeFields WantNormal)
-lookupGlobalOccRn' :: WhichGREs GREInfo -> RdrName -> RnM GlobalRdrElt
+lookupGlobalOccRn' :: WhichGREs GREInfo -> RdrName -> RnM Name
lookupGlobalOccRn' which_gres rdr_name =
- lookupExactOrOrig rdr_name id $ do
- mn <- lookupGlobalOccRn_base which_gres rdr_name
- case mn of
- Just n -> return n
+ lookupExactOrOrig rdr_name greName $ do
+ mb_gre <- lookupGlobalOccRn_base which_gres rdr_name
+ case mb_gre of
+ Just gre -> return (greName gre)
Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)
- ; nm <- unboundName (LF which_suggest WL_Global) rdr_name
- ; return $ localVanillaGRE NoParent nm }
+ ; unboundName (LF which_suggest WL_Global) rdr_name }
where which_suggest = case which_gres of
IncludeFields WantBoth -> WL_RecField
IncludeFields WantField -> WL_RecField
@@ -1333,7 +1338,7 @@ lookupGlobalOccRn_base which_gres rdr_name =
-- | Lookup a 'Name' in the 'GlobalRdrEnv', falling back to looking up
-- in the type environment it if fails.
-lookupGREInfo_GRE :: Name -> RnM GREInfo
+lookupGREInfo_GRE :: Name -> RnM GREInfo
lookupGREInfo_GRE name
= do { rdr_env <- getGlobalRdrEnv
; case lookupGRE_Name rdr_env name of
@@ -1740,7 +1745,7 @@ addUsedGRE warn_if_deprec gre
= do { case warn_if_deprec of
EnableDeprecationWarnings -> warnIfDeprecated gre
DisableDeprecationWarnings -> return ()
- ; unless (isLocalGRE gre) $
+ ; when (isImportedGRE gre) $ -- See Note [Using isImportedGRE in addUsedGRE]
do { env <- getGblEnv
-- Do not report the GREInfo (#23424)
; traceRn "addUsedGRE" (ppr $ greName gre)
@@ -1758,7 +1763,22 @@ addUsedGREs gres
(ppr $ map greName imp_gres)
; updTcRef (tcg_used_gres env) (imp_gres ++) }
where
- imp_gres = filterOut isLocalGRE gres
+ imp_gres = filter isImportedGRE gres
+ -- See Note [Using isImportedGRE in addUsedGRE]
+
+{- Note [Using isImportedGRE in addUsedGRE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In addUsedGRE, we want to add any used imported GREs to the tcg_used_gres field,
+so that we can emit appropriate warnings (see GHC.Rename.Names.warnUnusedImportDecls).
+
+We want to do this for GREs that were brought into scope through imports. As per
+Note [GlobalRdrElt provenance] in GHC.Types.Name.Reader, this means we should
+check that gre_imp is non-empty. Checking that gre_lcl is False is INCORRECT,
+because we might have obtained the GRE by an Exact or Orig direct reference,
+in which case we have both gre_lcl = False and gre_imp = emptyBag.
+
+Geting this wrong can lead to panics in e.g. bestImport, see #23240.
+-}
warnIfDeprecated :: GlobalRdrElt -> RnM ()
warnIfDeprecated gre@(GRE { gre_imp = iss })
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -260,18 +260,20 @@ rnExpr (HsVar _ (L l v))
; case mb_gre of {
Nothing -> rnUnboundVar v ;
Just gre ->
- do { if | Just fl <- recFieldLabel <$> recFieldInfo_maybe gre
+ do { let nm = greName gre
+ info = gre_info gre
+ ; if | IAmRecField fld_info <- info
-- Since GHC 9.4, such occurrences of record fields must be
-- unambiguous. For ambiguous occurrences, we arbitrarily pick one
-- matching GRE and add a name clash error
-- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn).
- -> do { let sel_name = flSelector fl
+ -> do { let sel_name = flSelector $ recFieldLabel fld_info
; this_mod <- getModule
; when (nameIsLocalOrFrom this_mod sel_name) $
checkThLocalName sel_name
; return (HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name)
}
- | greName gre == nilDataConName
+ | nm == nilDataConName
-- Treat [] as an ExplicitList, so that
-- OverloadedLists works correctly
-- Note [Empty lists] in GHC.Hs.Expr
@@ -279,7 +281,7 @@ rnExpr (HsVar _ (L l v))
-> rnExpr (ExplicitList noAnn [])
| otherwise
- -> finishHsVar (L (na2la l) $ greName gre)
+ -> finishHsVar (L (na2la l) nm)
}}}
rnExpr (HsIPVar x v)
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -152,7 +152,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- Excludes pattern-synonym binders
-- They are already in scope
traceRn "rnSrcDecls" (ppr id_bndrs) ;
- tc_envs <- extendGlobalRdrEnvRn (map (localVanillaGRE NoParent) id_bndrs) local_fix_env ;
+ tc_envs <- extendGlobalRdrEnvRn (map (mkLocalVanillaGRE NoParent) id_bndrs) local_fix_env ;
restoreEnvs tc_envs $ do {
-- Now everything is in scope, as the remaining renaming assumes.
@@ -2520,8 +2520,8 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do {
; let pat_syn_bndrs = concat [ conLikeName_Name name : map flSelector flds
| (name, con_info) <- names_with_fls
, let flds = conInfoFields con_info ]
- ; let gres = map (localConLikeGRE NoParent) names_with_fls
- ++ localFieldGREs NoParent names_with_fls
+ ; let gres = map (mkLocalConLikeGRE NoParent) names_with_fls
+ ++ mkLocalFieldGREs NoParent names_with_fls
-- Recall Note [Parents] in GHC.Types.Name.Reader:
--
-- pattern synonym constructors and their record fields have no parent
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -858,7 +858,7 @@ getLocalNonValBinders fixity_env
-- declaration, not just the name
new_simple :: LocatedN RdrName -> RnM GlobalRdrElt
new_simple rdr_name = do { nm <- newTopSrcBinder rdr_name
- ; return (localVanillaGRE NoParent nm) }
+ ; return (mkLocalVanillaGRE NoParent nm) }
new_tc :: DuplicateRecordFields -> FieldSelectors -> LTyClDecl GhcPs
-> RnM [GlobalRdrElt]
@@ -871,13 +871,13 @@ getLocalNonValBinders fixity_env
; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds
; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst con_names_with_flds) flds
; mapM_ (add_dup_fld_errs flds') con_names_with_flds
- ; let tc_gre = localTyConGRE (fmap (const tycon_name) tc_flav) tycon_name
+ ; let tc_gre = mkLocalTyConGRE (fmap (const tycon_name) tc_flav) tycon_name
fld_env = mk_fld_env con_names_with_flds flds'
- at_gres = zipWith (\ (_, at_flav) at_nm -> localTyConGRE (fmap (const tycon_name) at_flav) at_nm)
+ at_gres = zipWith (\ (_, at_flav) at_nm -> mkLocalTyConGRE (fmap (const tycon_name) at_flav) at_nm)
at_bndrs at_names
- sig_gres = map (localVanillaGRE (ParentIs tycon_name)) sig_names
- con_gres = map (localConLikeGRE (ParentIs tycon_name)) fld_env
- fld_gres = localFieldGREs (ParentIs tycon_name) fld_env
+ sig_gres = map (mkLocalVanillaGRE (ParentIs tycon_name)) sig_names
+ con_gres = map (mkLocalConLikeGRE (ParentIs tycon_name)) fld_env
+ fld_gres = mkLocalFieldGREs (ParentIs tycon_name) fld_env
sub_gres = at_gres ++ sig_gres ++ con_gres ++ fld_gres
; traceRn "getLocalNonValBinders new_tc" $
vcat [ text "tycon:" <+> ppr tycon_name
@@ -947,8 +947,8 @@ getLocalNonValBinders fixity_env
; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst sub_names) flds
; mapM_ (add_dup_fld_errs flds') sub_names
; let fld_env = mk_fld_env sub_names flds'
- con_gres = map (localConLikeGRE (ParentIs main_name)) fld_env
- field_gres = localFieldGREs (ParentIs main_name) fld_env
+ con_gres = map (mkLocalConLikeGRE (ParentIs main_name)) fld_env
+ field_gres = mkLocalFieldGREs (ParentIs main_name) fld_env
-- NB: the data family name is not bound here,
-- so we don't return a GlobalRdrElt for it here!
; return $ con_gres ++ field_gres }
=====================================
compiler/GHC/Rename/Unbound.hs
=====================================
@@ -105,10 +105,10 @@ mkUnboundNameRdr :: RdrName -> Name
mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
mkUnboundGRE :: OccName -> GlobalRdrElt
-mkUnboundGRE occ = localVanillaGRE NoParent $ mkUnboundName occ
+mkUnboundGRE occ = mkLocalVanillaGRE NoParent $ mkUnboundName occ
mkUnboundGRERdr :: RdrName -> GlobalRdrElt
-mkUnboundGRERdr rdr = localVanillaGRE NoParent $ mkUnboundNameRdr rdr
+mkUnboundGRERdr rdr = mkLocalVanillaGRE NoParent $ mkUnboundNameRdr rdr
reportUnboundName' :: WhatLooking -> RdrName -> RnM Name
reportUnboundName' what_look rdr = unboundName (LF what_look WL_Anywhere) rdr
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -611,7 +611,7 @@ instance Diagnostic TcRnMessage where
| isRecordSelector i = "record selector"
pp_category i = tyThingCategory i
what_is = pp_category ty_thing
- thing = ppr $ greOccName child
+ thing = ppr $ nameOccName child
parents = map ppr parent_names
TcRnConflictingExports occ child_gre1 ie1 child_gre2 ie2
-> mkSimpleDecorated $
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -1559,7 +1559,7 @@ data TcRnMessage where
-}
TcRnExportedParentChildMismatch :: Name -- ^ parent
-> TyThing
- -> GlobalRdrElt -- ^ child
+ -> Name -- ^ child
-> [Name] -> TcRnMessage
{-| TcRnConflictingExports is an error that occurs when different identifiers that
=====================================
compiler/GHC/Tc/Gen/Export.hs
=====================================
@@ -520,14 +520,13 @@ lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items
NameNotFound ->
do { ub <- reportUnboundName unboundName
; let l = getLoc n
- gre = localVanillaGRE NoParent ub
+ gre = mkLocalVanillaGRE NoParent ub
; return (L l (IEName noExtField (L (la2na l) ub)), gre)}
- FoundChild child@(GRE { gre_par = par }) ->
- do { checkPatSynParent spec_parent par child
- ; let child_nm = greName child
+ FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) ->
+ do { checkPatSynParent spec_parent par child_nm
; return (replaceLWrappedName n child_nm, child)
}
- IncorrectParent p c gs -> failWithDcErr p c gs
+ IncorrectParent p c gs -> failWithDcErr p (greName c) gs
-- Note [Typing Pattern Synonym Exports]
@@ -590,7 +589,7 @@ lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items
checkPatSynParent :: Name -- ^ Alleged parent type constructor
-- User wrote T( P, Q )
-> Parent -- The parent of P we discovered
- -> GlobalRdrElt
+ -> Name
-- ^ Either a
-- a) Pattern Synonym Constructor
-- b) A pattern synonym selector
@@ -598,13 +597,12 @@ checkPatSynParent :: Name -- ^ Alleged parent type constructor
checkPatSynParent _ (ParentIs {}) _
= return ()
-checkPatSynParent parent NoParent gre
+checkPatSynParent parent NoParent nm
| isUnboundName parent -- Avoid an error cascade
= return ()
| otherwise
= do { parent_ty_con <- tcLookupTyCon parent
- ; let nm = greName gre
; mpat_syn_thing <- tcLookupGlobal nm
-- 1. Check that the Id was actually from a thing associated with patsyns
@@ -615,7 +613,7 @@ checkPatSynParent parent NoParent gre
AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p
- _ -> failWithDcErr parent gre [] }
+ _ -> failWithDcErr parent nm [] }
where
psErr = exportErrCtxt "pattern synonym"
selErr = exportErrCtxt "pattern synonym record selector"
@@ -736,9 +734,9 @@ addExportErrCtxt ie = addErrCtxt exportCtxt
exportCtxt = text "In the export:" <+> ppr ie
-failWithDcErr :: Name -> GlobalRdrElt -> [Name] -> TcM a
+failWithDcErr :: Name -> Name -> [Name] -> TcM a
failWithDcErr parent child parents = do
- ty_thing <- tcLookupGlobal (greName child)
+ ty_thing <- tcLookupGlobal child
failWithTc $ TcRnExportedParentChildMismatch parent ty_thing child parents
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1413,20 +1413,18 @@ disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
lookupField :: FieldGlobalRdrElt
-> LHsRecUpdField GhcRn GhcRn
-> TcM (LHsRecUpdField GhcTc GhcRn)
- lookupField fl (L l upd)
+ lookupField fld_gre (L l upd)
= do { let L loc af = hfbLHS upd
- rdr = ambiguousFieldOccRdrName af
- mb_gre = pickGREs rdr [fl]
- -- NB: this GRE can be 'Nothing' when in GHCi.
- -- See test T10439.
+ lbl = ambiguousFieldOccRdrName af
+ mb_gre = pickGREs lbl [fld_gre]
+ -- NB: this GRE can be 'Nothing' when in GHCi.
+ -- See test T10439.
-- Mark the record fields as used, now that we have disambiguated.
-- There is no risk of duplicate deprecation warnings, as we have
-- not marked the GREs as used previously.
; setSrcSpanA loc $ mapM_ (addUsedGRE EnableDeprecationWarnings) mb_gre
- ; sel <- tcLookupId $ flSelector $ fieldGRELabel fl
- ; let L loc af = hfbLHS upd
- lbl = ambiguousFieldOccRdrName af
+ ; sel <- tcLookupId (greName fld_gre)
; return $ L l HsFieldBind
{ hfbAnn = hfbAnn upd
, hfbLHS = L (l2l loc) $ Unambiguous sel (L (l2l loc) lbl)
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -1938,8 +1938,8 @@ lookupName :: Bool -- True <=> type namespace
-- False <=> value namespace
-> String -> TcM (Maybe TH.Name)
lookupName is_type_name s
- = do { mb_gre <- lookupSameOccRn_maybe rdr_name
- ; return (fmap (reifyName . greName) mb_gre) }
+ = do { mb_nm <- lookupSameOccRn_maybe rdr_name
+ ; return (fmap reifyName mb_nm) }
where
th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M'
@@ -1999,15 +1999,12 @@ lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
lookupThName_maybe th_name
= do { let guesses = thRdrNameGuesses th_name
; case guesses of
- { [for_sure] -> get_name $ lookupSameOccRn_maybe for_sure
+ { [for_sure] -> lookupSameOccRn_maybe for_sure
; _ ->
- do { names <- mapMaybeM (get_name . lookupOccRn_maybe) guesses
+ do { gres <- mapMaybeM lookupOccRn_maybe guesses
-- Pick the first that works
-- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
- ; return (listToMaybe names) } } }
- where
- get_name :: TcM (Maybe GlobalRdrElt) -> TcM (Maybe Name)
- get_name = fmap (fmap greName)
+ ; return (fmap greName $ listToMaybe gres) } } }
tcLookupTh :: Name -> TcM TcTyThing
-- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -512,6 +512,8 @@ data TcGblEnv
-- See Note [Tracking unused binding and imports]
tcg_dus :: DefUses,
tcg_used_gres :: TcRef [GlobalRdrElt],
+ -- ^ INVARIANT: all these GREs were imported; that is,
+ -- they all have a non-empty gre_imp field.
tcg_keep :: TcRef NameSet,
tcg_th_used :: TcRef Bool,
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -68,13 +68,13 @@ module GHC.Types.Name.Reader (
-- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'
GlobalRdrEltX(..), GlobalRdrElt, IfGlobalRdrElt, FieldGlobalRdrElt,
greName, forceGlobalRdrEnv, hydrateGlobalRdrEnv,
- isLocalGRE, isRecFldGRE,
+ isLocalGRE, isImportedGRE, isRecFldGRE,
fieldGREInfo,
isDuplicateRecFldGRE, isNoFieldSelectorGRE, isFieldSelectorGRE,
unQualOK, qualSpecOK, unQualSpecOK,
pprNameProvenance,
- vanillaGRE, localVanillaGRE, localTyConGRE,
- localConLikeGRE, localFieldGREs,
+ mkGRE, mkExactGRE, mkLocalGRE, mkLocalVanillaGRE, mkLocalTyConGRE,
+ mkLocalConLikeGRE, mkLocalFieldGREs,
gresToNameSet,
-- ** Shadowing
@@ -526,7 +526,8 @@ type GlobalRdrEnvX info = OccEnv [GlobalRdrEltX info]
-- | Global Reader Element
--
--- An element of the 'GlobalRdrEnv'.
+-- Something in scope in the renamer; usually a member of the 'GlobalRdrEnv'.
+-- See Note [GlobalRdrElt provenance].
type GlobalRdrElt = GlobalRdrEltX GREInfo
@@ -538,7 +539,8 @@ type IfGlobalRdrElt = GlobalRdrEltX ()
-- | Global Reader Element
--
--- An element of the 'GlobalRdrEnv'.
+-- Something in scope in the renamer; usually a member of the 'GlobalRdrEnv'.
+-- See Note [GlobalRdrElt provenance].
--
-- Why do we parametrise over the 'gre_info' field? See Note [IfGlobalRdrEnv].
data GlobalRdrEltX info
@@ -546,6 +548,8 @@ data GlobalRdrEltX info
, gre_par :: !Parent -- ^ See Note [Parents]
, gre_lcl :: !Bool -- ^ True <=> the thing was defined locally
, gre_imp :: !(Bag ImportSpec) -- ^ In scope through these imports
+ -- See Note [GlobalRdrElt provenance] for the relation between gre_lcl and gre_imp.
+
, gre_info :: info
-- ^ Information the renamer knows about this particular 'Name'.
--
@@ -554,8 +558,7 @@ data GlobalRdrEltX info
--
-- Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo.
} deriving (Data)
- -- INVARIANT: either gre_lcl = True or gre_imp is non-empty
- -- See Note [GlobalRdrElt provenance]
+
{- Note [IfGlobalRdrEnv]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -623,16 +626,32 @@ hasParent p _ = p
{- Note [GlobalRdrElt provenance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance",
-i.e. how the Name came to be in scope. It can be in scope two ways:
- - gre_lcl = True: it is bound in this module
- - gre_imp: a list of all the imports that brought it into scope
+i.e. how the Name came to be in scope. It can be in scope in one of the following
+three ways:
+
+ A. The Name was locally bound, in the current module.
+ gre_lcl = True
+
+ The renamer adds this Name to the GlobalRdrEnv after renaming the binding.
+ See the calls to "extendGlobalRdrEnvRn" in GHC.Rename.Module.rnSrcDecls.
+
+ B. The Name was imported
+ gre_imp = Just imps <=> brought into scope by the imports "imps"
+
+ The renamer adds this Name to the GlobalRdrEnv after processing the imports.
+ See GHC.Rename.Names.filterImports and GHC.Tc.Module.tcRnImports.
-It's an INVARIANT that you have one or the other; that is, either
-gre_lcl is True, or gre_imp is non-empty.
+ C. We followed an exact reference (i.e. an Exact or Orig RdrName)
+ gre_lcl = False, gre_imp = Nothing
-It is just possible to have *both* if there is a module loop: a Name
-is defined locally in A, and also brought into scope by importing a
-module that SOURCE-imported A. Example (#7672):
+ In this case, we directly fetch a Name and its GREInfo from direct reference.
+ We don't add it to the GlobalRdrEnv. See "GHC.Rename.Env.lookupExactOrOrig".
+
+It is just about possible to have *both* gre_lcl = True and gre_imp = Just imps.
+This can happen with module loops: a Name is defined locally in A, and also
+brought into scope by importing a module that SOURCE-imported A.
+
+Example (#7672):
A.hs-boot module A where
data T
@@ -710,42 +729,47 @@ those. For T that will mean we have
That's why plusParent picks the "best" case.
-}
-vanillaGRE :: (Name -> Maybe ImportSpec) -> Parent -> Name -> GlobalRdrElt
-vanillaGRE prov_fn par n =
+mkGRE :: (Name -> Maybe ImportSpec) -> GREInfo -> Parent -> Name -> GlobalRdrElt
+mkGRE prov_fn info par n =
case prov_fn n of
-- Nothing => bound locally
-- Just is => imported from 'is'
Nothing -> GRE { gre_name = n, gre_par = par
, gre_lcl = True, gre_imp = emptyBag
- , gre_info = Vanilla }
+ , gre_info = info }
Just is -> GRE { gre_name = n, gre_par = par
, gre_lcl = False, gre_imp = unitBag is
- , gre_info = Vanilla }
+ , gre_info = info }
+
+mkExactGRE :: Name -> GREInfo -> GlobalRdrElt
+mkExactGRE nm info =
+ GRE { gre_name = nm, gre_par = NoParent
+ , gre_lcl = False, gre_imp = emptyBag
+ , gre_info = info }
-localVanillaGRE :: Parent -> Name -> GlobalRdrElt
-localVanillaGRE = vanillaGRE (const Nothing)
+mkLocalGRE :: GREInfo -> Parent -> Name -> GlobalRdrElt
+mkLocalGRE = mkGRE (const Nothing)
+
+mkLocalVanillaGRE :: Parent -> Name -> GlobalRdrElt
+mkLocalVanillaGRE = mkLocalGRE Vanilla
-- | Create a local 'GlobalRdrElt' for a 'TyCon'.
-localTyConGRE :: TyConFlavour Name
+mkLocalTyConGRE :: TyConFlavour Name
-> Name
-> GlobalRdrElt
-localTyConGRE flav nm =
- ( localVanillaGRE par nm )
- { gre_info = IAmTyCon flav }
+mkLocalTyConGRE flav nm = mkLocalGRE (IAmTyCon flav) par nm
where
par = case tyConFlavourAssoc_maybe flav of
Nothing -> NoParent
Just p -> ParentIs p
-localConLikeGRE :: Parent -> (ConLikeName, ConInfo) -> GlobalRdrElt
-localConLikeGRE p (con_nm, con_info) =
- ( localVanillaGRE p $ conLikeName_Name con_nm )
- { gre_info = IAmConLike con_info }
+mkLocalConLikeGRE :: Parent -> (ConLikeName, ConInfo) -> GlobalRdrElt
+mkLocalConLikeGRE p (con_nm, con_info) =
+ mkLocalGRE (IAmConLike con_info) p (conLikeName_Name con_nm )
-localFieldGREs :: Parent -> [(ConLikeName, ConInfo)] -> [GlobalRdrElt]
-localFieldGREs p cons =
- [ ( localVanillaGRE p fld_nm )
- { gre_info = IAmRecField fld_info }
+mkLocalFieldGREs :: Parent -> [(ConLikeName, ConInfo)] -> [GlobalRdrElt]
+mkLocalFieldGREs p cons =
+ [ mkLocalGRE (IAmRecField fld_info) p fld_nm
| (S.Arg fld_nm fl, fl_cons) <- flds
, let fld_info = RecFieldInfo { recFieldLabel = fl
, recFieldCons = fl_cons } ]
@@ -1147,9 +1171,17 @@ getGRE_NameQualifier_maybes env name
| lcl = Nothing
| otherwise = Just $ map (is_as . is_decl) (bagToList iss)
+-- | Is this 'GlobalRdrElt' defined locally?
isLocalGRE :: GlobalRdrEltX info -> Bool
isLocalGRE (GRE { gre_lcl = lcl }) = lcl
+-- | Is this 'GlobalRdrElt' imported?
+--
+-- Not just the negation of 'isLocalGRE', because it might be an Exact or
+-- Orig name reference. See Note [GlobalRdrElt provenance].
+isImportedGRE :: GlobalRdrEltX info -> Bool
+isImportedGRE (GRE { gre_imp = imps }) = not $ isEmptyBag imps
+
-- | Is this a record field GRE?
--
-- Important: does /not/ consult the 'GreInfo' field.
=====================================
compiler/GHC/Types/TyThing.hs
=====================================
@@ -287,7 +287,7 @@ tyThingLocalGREs ty_thing =
ATyCon t
| Just c <- tyConClass_maybe t
-> myself NoParent
- : ( map (localVanillaGRE (ParentIs $ className c) . getName) (classMethods c)
+ : ( map (mkLocalVanillaGRE (ParentIs $ className c) . getName) (classMethods c)
++ map tc_GRE (classATs c) )
| otherwise
-> let dcs = tyConDataCons t
@@ -296,7 +296,7 @@ tyThingLocalGREs ty_thing =
in myself NoParent
: map (dc_GRE par) dcs
++
- localFieldGREs par
+ mkLocalFieldGREs par
[ (mk_nm dc, con_info)
| dc <- dcs
, let con_info = conLikeConInfo (RealDataCon dc) ]
@@ -308,7 +308,7 @@ tyThingLocalGREs ty_thing =
RealDataCon dc -> ParentIs $ tyConName $ dataConTyCon dc
in
myself par :
- localFieldGREs par
+ mkLocalFieldGREs par
[(conLikeConLikeName con, conLikeConInfo con)]
AnId id
| RecSelId { sel_tycon = RecSelData tc } <- idDetails id
@@ -318,17 +318,15 @@ tyThingLocalGREs ty_thing =
_ -> [ myself NoParent ]
where
tc_GRE :: TyCon -> GlobalRdrElt
- tc_GRE at = localTyConGRE
+ tc_GRE at = mkLocalTyConGRE
(fmap tyConName $ tyConFlavour at)
(tyConName at)
dc_GRE :: Parent -> DataCon -> GlobalRdrElt
dc_GRE par dc =
let con_info = conLikeConInfo (RealDataCon dc)
- in localConLikeGRE par (DataConName $ dataConName dc, con_info)
+ in mkLocalConLikeGRE par (DataConName $ dataConName dc, con_info)
myself :: Parent -> GlobalRdrElt
- myself p =
- (localVanillaGRE p (getName ty_thing))
- { gre_info = tyThingGREInfo ty_thing }
+ myself p = mkLocalGRE (tyThingGREInfo ty_thing) p (getName ty_thing)
-- | Obtain information pertinent to the renamer about a particular 'TyThing'.
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e81f140c6e8297273ef20addbcf71be54fbe28e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e81f140c6e8297273ef20addbcf71be54fbe28e
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230601/812514b4/attachment-0001.html>
More information about the ghc-commits
mailing list