diff options
| -rw-r--r-- | compiler/GHC/Rename/Env.hs | 35 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Export.hs | 101 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Expr.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Instance/Class.hs | 4 |
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 |