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