[Git][ghc/ghc][master] Cleanup of dynflags override in export renaming
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat May 13 03:51:24 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
5cad28e7 by Bartłomiej Cieślar at 2023-05-12T23:51:06-04:00
Cleanup of dynflags override in export renaming
The deprecation warnings are normally emitted whenever the name's GRE is being looked up, which calls the GHC.Rename.Env.addUsedGRE function. We do not want those warnings to be emitted when renaming export lists, so they are artificially turned off by removing all warning categories from DynFlags at the beginning of GHC.Tc.Gen.Export.rnExports. This commit removes that dependency by unifying the function used for GRE lookup in lookup_ie to lookupGreAvailRn and disabling the call to addUsedGRE in said function (the warnings are also disabled in a call to lookupSubBndrOcc_helper in lookupChildrenExport), as per #17957. This commit also changes the setting for whether to warn about deprecated names in addUsedGREs to be an explicit enum instead of a boolean.
- - - - -
4 changed files:
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Instance/Class.hs
Changes:
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -54,6 +54,7 @@ module GHC.Rename.Env (
lookupQualifiedDoName, lookupNameWithQualifier,
-- Constructing usage information
+ DeprecationWarnings(..),
addUsedGRE, addUsedGREs, addUsedDataCons,
@@ -406,7 +407,8 @@ lookupInstDeclBndr cls what rdr
-- to use a qualified name for the method
-- (Although it'd make perfect sense.)
; mb_name <- lookupSubBndrOcc
- False -- False => we don't give deprecated
+ DisableDeprecationWarnings
+ -- we don't give deprecated
-- warnings when a deprecated class
-- method is defined. We only warn
-- when it's used
@@ -551,7 +553,7 @@ lookupRecFieldOcc mb_con rdr_name
, text "rdr_name:" <+> ppr rdr_name
, text "flds:" <+> ppr flds
, text "mb_gre:" <+> ppr mb_gre ]
- ; mapM_ (addUsedGRE True) mb_gre
+ ; mapM_ (addUsedGRE EnableDeprecationWarnings) mb_gre
; return $ flSelector . fieldGRELabel <$> mb_gre }
; case mb_nm of
{ Nothing -> do { addErr (badFieldConErr con lbl)
@@ -681,7 +683,7 @@ lookupGlobalOccRn will find it.
-- | Used in export lists to lookup the children.
-lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName
+lookupSubBndrOcc_helper :: Bool -> DeprecationWarnings -> Name -> RdrName
-> RnM ChildLookupResult
lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name
| isUnboundName parent
@@ -842,7 +844,7 @@ instance Outputable ChildLookupResult where
= text "IncorrectParent"
<+> hsep [ppr p, ppr $ greName g, ppr ns]
-lookupSubBndrOcc :: Bool
+lookupSubBndrOcc :: DeprecationWarnings
-> Name -- Parent
-> SDoc
-> RdrName
@@ -1407,7 +1409,7 @@ lookupFieldGREs env (L loc rdr)
lookupGlobalOccRn_overloaded :: RdrName -> RnM (Maybe GlobalRdrElt)
lookupGlobalOccRn_overloaded rdr_name =
lookupExactOrOrig_maybe rdr_name id $
- do { res <- lookupGreRn_helper (IncludeFields WantNormal) rdr_name
+ do { res <- lookupGreRn_helper (IncludeFields WantNormal) rdr_name EnableDeprecationWarnings
; case res of
GreNotFound -> lookupOneQualifiedNameGHCi WantNormal rdr_name
OneNameMatch gre -> return $ Just gre
@@ -1627,7 +1629,7 @@ lookupGreRn_maybe :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt)
-- Uses addUsedRdrName to record use and deprecations
lookupGreRn_maybe which_gres rdr_name
= do
- res <- lookupGreRn_helper which_gres rdr_name
+ res <- lookupGreRn_helper which_gres rdr_name EnableDeprecationWarnings
case res of
OneNameMatch gre -> return $ Just gre
MultipleNames gres -> do
@@ -1663,12 +1665,12 @@ is enabled then we defer the selection until the typechecker.
-- Internal Function
-lookupGreRn_helper :: WhichGREs GREInfo -> RdrName -> RnM GreLookupResult
-lookupGreRn_helper which_gres rdr_name
+lookupGreRn_helper :: WhichGREs GREInfo -> RdrName -> DeprecationWarnings -> RnM GreLookupResult
+lookupGreRn_helper which_gres rdr_name warn_if_deprec
= do { env <- getGlobalRdrEnv
; case lookupGRE_RdrName which_gres env rdr_name of
[] -> return GreNotFound
- [gre] -> do { addUsedGRE True gre
+ [gre] -> do { addUsedGRE warn_if_deprec gre
; return (OneNameMatch gre) }
-- Don't record usage for ambiguous names
-- until we know which is meant
@@ -1680,7 +1682,7 @@ lookupGreAvailRn :: RdrName -> RnM (Maybe GlobalRdrElt)
-- Uses addUsedRdrName to record use and deprecations
lookupGreAvailRn rdr_name
= do
- mb_gre <- lookupGreRn_helper (IncludeFields WantNormal) rdr_name
+ mb_gre <- lookupGreRn_helper (IncludeFields WantNormal) rdr_name DisableDeprecationWarnings
case mb_gre of
GreNotFound ->
do
@@ -1726,11 +1728,18 @@ addUsedDataCons rdr_env tycon
| dc <- tyConDataCons tycon
, Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ]
-addUsedGRE :: Bool -> GlobalRdrElt-> RnM ()
+-- | Whether to report deprecation warnings when registering a used GRE
+data DeprecationWarnings
+ = DisableDeprecationWarnings
+ | EnableDeprecationWarnings
+
+addUsedGRE :: DeprecationWarnings -> GlobalRdrElt-> RnM ()
-- Called for both local and imported things
-- Add usage *and* warn if deprecated
addUsedGRE warn_if_deprec gre
- = do { when warn_if_deprec (warnIfDeprecated gre)
+ = do { case warn_if_deprec of
+ EnableDeprecationWarnings -> warnIfDeprecated gre
+ DisableDeprecationWarnings -> return ()
; unless (isLocalGRE gre) $
do { env <- getGblEnv
; traceRn "addUsedGRE" (ppr gre)
@@ -2065,7 +2074,7 @@ lookupBindGroupOcc ctxt what rdr_name
else lookup_top (`elemNameSet` ns)
where
lookup_cls_op cls
- = lookupSubBndrOcc True cls doc rdr_name
+ = lookupSubBndrOcc EnableDeprecationWarnings cls doc rdr_name
where
doc = text "method of class" <+> quotes (ppr cls)
=====================================
compiler/GHC/Tc/Gen/Export.hs
=====================================
@@ -167,10 +167,6 @@ rnExports :: Bool -- False => no 'module M(..) where' header at all
rnExports explicit_mod exports
= checkNoErrs $ -- Fail if anything in rnExports finds
-- an error fails, to avoid error cascade
- updTopFlags wopt_unset_all_custom $
- -- Do not report deprecations arising from the export
- -- list, to avoid bleating about re-exporting a deprecated
- -- thing (especially via 'module Foo' export item)
do { hsc_env <- getTopEnv
; tcg_env <- getGblEnv
; let dflags = hsc_dflags hsc_env
@@ -336,73 +332,70 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
-------------
lookup_ie :: ExportOccMap -> IE GhcPs -> RnM (Maybe (ExportOccMap, IE GhcRn, AvailInfo))
- lookup_ie occs ie@(IEVar ann (L l rdr))
- = do mb_gre <- lookupGreAvailRn $ ieWrappedName rdr
+ lookup_ie occs ie@(IEVar ann l)
+ = do mb_gre <- lookupGreAvailRn $ lieWrappedName l
for mb_gre $ \ gre -> do
let avail = availFromGRE gre
name = greName gre
occs' <- check_occs occs ie [gre]
- return (occs', IEVar ann (L l (replaceWrappedName rdr name)), avail)
+ return (occs', IEVar ann (replaceLWrappedName l name), avail)
- lookup_ie occs ie@(IEThingAbs ann (L l rdr))
- = do mb_gre <- lookupGreAvailRn $ ieWrappedName rdr
+ lookup_ie occs ie@(IEThingAbs ann l)
+ = do mb_gre <- lookupGreAvailRn $ lieWrappedName l
for mb_gre $ \ gre -> do
let avail = availFromGRE gre
name = greName gre
occs' <- check_occs occs ie [gre]
return ( occs'
- , IEThingAbs ann (L l (replaceWrappedName rdr name))
+ , IEThingAbs ann (replaceLWrappedName l name)
, avail)
- lookup_ie occs ie@(IEThingAll ann n')
- = do
- (par, kids) <- lookup_ie_all ie n'
- let name = greName par
- avails = map greName kids
- occs' <- check_occs occs ie (par:kids)
- return $ Just
- ( occs'
- , IEThingAll ann (replaceLWrappedName n' name)
- , AvailTC name (name:avails))
+ lookup_ie occs ie@(IEThingAll ann l)
+ = do mb_gre <- lookupGreAvailRn $ lieWrappedName l
+ for mb_gre $ \ par -> do
+ all_kids <- lookup_ie_kids_all ie l par
+ let name = greName par
+ kids_avails = map greName all_kids
+ occs' <- check_occs occs ie (par:all_kids)
+ return ( occs'
+ , IEThingAll ann (replaceLWrappedName l name)
+ , AvailTC name (name:kids_avails))
lookup_ie occs ie@(IEThingWith ann l wc sub_rdrs)
- = do
- (par_gre, subs, with_gres)
- <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs
-
- wc_gres <-
- case wc of
- NoIEWildcard -> return []
- IEWildcard _ -> snd <$> lookup_ie_all ie l
-
- let par = greName par_gre
- all_names = par : map greName (with_gres ++ wc_gres)
- gres = par_gre : with_gres ++ wc_gres
-
- occs' <- check_occs occs ie gres
- return $ Just $
- ( occs'
- , IEThingWith ann (replaceLWrappedName l par) wc subs
- , AvailTC par all_names)
+ = do mb_gre <- addExportErrCtxt ie
+ $ lookupGreAvailRn $ lieWrappedName l
+ for mb_gre $ \ par -> do
+ (subs, with_kids)
+ <- addExportErrCtxt ie
+ $ lookup_ie_kids_with par sub_rdrs
+
+ wc_kids <-
+ case wc of
+ NoIEWildcard -> return []
+ IEWildcard _ -> lookup_ie_kids_all ie l par
+
+ let name = greName par
+ all_kids = with_kids ++ wc_kids
+ kids_avails = map greName all_kids
+ occs' <- check_occs occs ie (par:all_kids)
+ return ( occs'
+ , IEThingWith ann (replaceLWrappedName l name) wc subs
+ , AvailTC name (name:kids_avails))
lookup_ie _ _ = panic "lookup_ie" -- Other cases covered earlier
- lookup_ie_with :: LIEWrappedName GhcPs -> [LIEWrappedName GhcPs]
- -> RnM (GlobalRdrElt, [LIEWrappedName GhcRn], [GlobalRdrElt])
- lookup_ie_with (L _ rdr) sub_rdrs =
- do { gre <- lookupGlobalOccRn $ ieWrappedName rdr
- ; let name = greName gre
+ lookup_ie_kids_with :: GlobalRdrElt -> [LIEWrappedName GhcPs]
+ -> RnM ([LIEWrappedName GhcRn], [GlobalRdrElt])
+ lookup_ie_kids_with gre sub_rdrs =
+ do { let name = greName gre
; kids <- lookupChildrenExport name sub_rdrs
- ; if isUnboundName name
- then return (gre, [], [gre])
- else return (gre, map fst kids, map snd kids) }
-
- lookup_ie_all :: IE GhcPs -> LIEWrappedName GhcPs
- -> RnM (GlobalRdrElt, [GlobalRdrElt])
- lookup_ie_all ie (L _ rdr) =
- do { gre <- lookupGlobalOccRn $ ieWrappedName rdr
- ; let name = greName gre
+ ; return (map fst kids, map snd kids) }
+
+ lookup_ie_kids_all :: IE GhcPs -> LIEWrappedName GhcPs -> GlobalRdrElt
+ -> RnM [GlobalRdrElt]
+ lookup_ie_kids_all ie (L _ rdr) gre =
+ do { let name = greName gre
gres = findChildren kids_env name
; addUsedKids (ieWrappedName rdr) gres
; when (null gres) $
@@ -411,7 +404,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
else -- This occurs when you export T(..), but
-- only import T abstractly, or T is a synonym.
addErr (TcRnExportHiddenComponents ie)
- ; return (gre, gres) }
+ ; return gres }
-------------
lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn))
@@ -510,7 +503,7 @@ lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items
doOne n = do
let bareName = (ieWrappedName . unLoc) n
- lkup v = lookupSubBndrOcc_helper False True
+ lkup v = lookupSubBndrOcc_helper False DisableDeprecationWarnings -- Do not report export list deprecations
spec_parent (setRdrNameSpace bareName v)
name <- combineChildLookupResult $ map lkup $
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -55,7 +55,7 @@ import GHC.Tc.Gen.Bind ( tcLocalBinds )
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Rename.Expr ( mkExpandedExpr )
-import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls )
+import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls, DeprecationWarnings(EnableDeprecationWarnings) )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
import GHC.Tc.Gen.Match
@@ -1417,7 +1417,7 @@ disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
-- 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 True) mb_gre
+ ; setSrcSpanA loc $ mapM_ (addUsedGRE EnableDeprecationWarnings) mb_gre
; sel <- tcLookupId $ flSelector $ fieldGRELabel fl
; let L loc af = hfbLHS upd
lbl = ambiguousFieldOccRdrName af
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -23,7 +23,7 @@ import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Origin (InstanceWhat (..), SafeOverlapping)
import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )
-import GHC.Rename.Env( addUsedGRE )
+import GHC.Rename.Env( addUsedGRE, DeprecationWarnings(EnableDeprecationWarnings) )
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
@@ -949,7 +949,7 @@ matchHasField dflags short_cut clas tys
-- it must not be higher-rank.
; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty
then do { -- See Note [Unused name reporting and HasField]
- addUsedGRE True gre
+ addUsedGRE EnableDeprecationWarnings gre
; keepAlive (greName gre)
; return OneInst { cir_new_theta = theta
, cir_mk_ev = mk_ev
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5cad28e73bf9a1a535fa9ed22800156c1ba2e6c8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5cad28e73bf9a1a535fa9ed22800156c1ba2e6c8
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/20230512/8a629e4f/attachment-0001.html>
More information about the ghc-commits
mailing list