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 files changed, 73 insertions, 71 deletions

diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 49fdde1bc6..03a9a1fdd5 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/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)
 
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index 620b0a9f5e..7aca2d87b8 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/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 $
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 8a7ce396bf..2b6234657c 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/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
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index 349ea1e34c..43fc9dbdb9 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/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