[Git][ghc/ghc][master] Report deprecated fields bound by record wildcards when used
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Aug 14 17:47:03 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
524c60c8 by Bartłomiej Cieślar at 2023-08-14T13:46:33-04:00
Report deprecated fields bound by record wildcards when used
This commit ensures that we emit the appropriate warnings when
a deprecated record field bound by a record wildcard is used.
For example:
module A where
data Foo = Foo {x :: Int, y :: Bool, z :: Char}
{-# DEPRECATED x "Don't use x" #-}
{-# WARNING y "Don't use y" #-}
module B where
import A
foo (Foo {..}) = x
This will cause us to emit a "Don't use x" warning, with location the
location of the record wildcard. Note that we don't warn about `y`,
because it is unused in the RHS of `foo`.
Fixes #23382
- - - - -
13 changed files:
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Types/Name/Set.hs
- + libraries/ghc-prim/ghc-prim.cabal
- + testsuite/tests/rename/should_compile/RecordWildCardDeprecation.hs
- + testsuite/tests/rename/should_compile/RecordWildCardDeprecation.stderr
- + testsuite/tests/rename/should_compile/RecordWildCardDeprecation_aux.hs
- testsuite/tests/rename/should_compile/all.T
Changes:
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -4,7 +4,7 @@
{-|
Module : GHC.Hs.Utils
Description : Generic helpers for the HsSyn type.
-Copyright : (c) The University of Glasgow, 1992-2006
+Copyright : (c) The University of Glasgow, 1992-2023
Here we collect a variety of helper functions that construct or
analyse HsSyn. All these functions deal with generic HsSyn; functions
@@ -35,8 +35,10 @@ just attach noSrcSpan to everything.
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# LANGUAGE RecordWildCards #-}
module GHC.Hs.Utils(
-- * Terms
@@ -105,7 +107,9 @@ module GHC.Hs.Utils(
hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
-- * Collecting implicit binders
- lStmtsImplicits, hsValBindsImplicits, lPatImplicits
+ ImplicitFieldBinders(..),
+ lStmtsImplicits, hsValBindsImplicits, lPatImplicits,
+ lHsRecFieldsImplicits
) where
import GHC.Prelude hiding (head, init, last, tail)
@@ -151,7 +155,6 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import Control.Arrow ( first )
-import Data.Either ( partitionEithers )
import Data.Foldable ( toList )
import Data.List ( partition )
import Data.List.NonEmpty ( nonEmpty )
@@ -1677,32 +1680,69 @@ constructor is an *occurrence* not a binding site
* *
************************************************************************
-The job of this family of functions is to run through binding sites and find the set of all Names
-that were defined "implicitly", without being explicitly written by the user.
+The job of the following family of functions is to run through binding sites and find
+the set of all Names that were defined "implicitly", without being explicitly written
+by the user.
-The main purpose is to find names introduced by record wildcards so that we can avoid
-warning the user when they don't use those names (#4404)
+Note [Collecting implicit binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We collect all the RHS Names that are implicitly introduced by record wildcards,
+so that we can:
+
+ - avoid warning the user when they don't use those names (#4404),
+ - report deprecation warnings for deprecated fields that are used (#23382).
+
+The functions that collect implicit binders return a collection of 'ImplicitFieldBinders',
+which associates each implicitly-introduced record field with the bound variables in the
+RHS of the record field pattern, e.g. in
+
+ data R = MkR { fld :: Int }
+ foo (MkR { .. }) = fld
+
+the renamer will elaborate this to
+
+ foo (MkR { fld = fld_var }) = fld_var
+
+and the implicit binders function will return
+
+ [ ImplicitFieldBinders { implFlBndr_field = fld
+ , implFlBndr_binders = [fld_var] } ]
+
+This information is then used:
-Since the addition of -Wunused-record-wildcards, this function returns a pair
-of [(SrcSpan, [Name])]. Each element of the list is one set of implicit
-binders, the first component of the tuple is the document describes the possible
-fix to the problem (by removing the ..).
+ - in the calls to GHC.Rename.Utils.checkUnusedRecordWildcard, to emit
+ a warning when a record wildcard binds no new variables (redundant record wildcard)
+ or none of the bound variables are used (unused record wildcard).
+ - in GHC.Rename.Utils.deprecateUsedRecordWildcard, to emit a warning
+ when the field is deprecated and any of the binders are used.
+
+NOTE: the implFlBndr_binders field should always be a singleton
+ (since the RHS of an implicit binding should always be a VarPat,
+ created in rnHsRecPatsAndThen.mkVarPat)
-This means there is some unfortunate coupling between this function and where it
-is used but it's only used for one specific purpose in one place so it seemed
-easier.
-}
+-- | All binders corresponding to a single implicit record field pattern.
+--
+-- See Note [Collecting implicit binders].
+data ImplicitFieldBinders
+ = ImplicitFieldBinders { implFlBndr_field :: Name
+ -- ^ The 'Name' of the record field
+ , implFlBndr_binders :: [Name]
+ -- ^ The binders of the RHS of the record field pattern
+ -- (in practice, always a singleton: see Note [Collecting implicit binders])
+ }
+
lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]
- -> [(SrcSpan, [Name])]
+ -> [(SrcSpan, [ImplicitFieldBinders])]
lStmtsImplicits = hs_lstmts
where
hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]
- -> [(SrcSpan, [Name])]
+ -> [(SrcSpan, [ImplicitFieldBinders])]
hs_lstmts = concatMap (hs_stmt . unLoc)
hs_stmt :: StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))
- -> [(SrcSpan, [Name])]
+ -> [(SrcSpan, [ImplicitFieldBinders])]
hs_stmt (BindStmt _ pat _) = lPatImplicits pat
hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
@@ -1719,19 +1759,26 @@ lStmtsImplicits = hs_lstmts
hs_local_binds (HsIPBinds {}) = []
hs_local_binds (EmptyLocalBinds _) = []
-hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]
+hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR)
+ -> [(SrcSpan, [ImplicitFieldBinders])]
hsValBindsImplicits (XValBindsLR (NValBinds binds _))
= concatMap (lhsBindsImplicits . snd) binds
hsValBindsImplicits (ValBinds _ binds _)
= lhsBindsImplicits binds
-lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])]
+lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [ImplicitFieldBinders])]
lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) []
where
lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
lhs_bind _ = []
-lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])]
+-- | Collect all record wild card binders in the given pattern.
+--
+-- These are all the variables bound in all (possibly nested) record wildcard patterns
+-- appearing inside the pattern.
+--
+-- See Note [Collecting implicit binders].
+lPatImplicits :: LPat GhcRn -> [(SrcSpan, [ImplicitFieldBinders])]
lPatImplicits = hs_lpat
where
hs_lpat lpat = hs_pat (unLoc lpat)
@@ -1745,28 +1792,41 @@ lPatImplicits = hs_lpat
hs_pat (ParPat _ _ pat _) = hs_lpat pat
hs_pat (ListPat _ pats) = hs_lpats pats
hs_pat (TuplePat _ pats _) = hs_lpats pats
-
hs_pat (SigPat _ pat _) = hs_lpat pat
- hs_pat (ConPat {pat_con=con, pat_args=ps}) = details con ps
+ hs_pat (ConPat {pat_args=ps}) = details ps
hs_pat _ = []
- details :: LocatedN Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]
- details _ (PrefixCon _ ps) = hs_lpats ps
- details n (RecCon fs) =
- [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]
- ++ hs_lpats explicit_pats
-
- where implicit_pats = map (hfbRHS . unLoc) implicit
- explicit_pats = map (hfbRHS . unLoc) explicit
-
+ details :: HsConPatDetails GhcRn -> [(SrcSpan, [ImplicitFieldBinders])]
+ details (PrefixCon _ ps) = hs_lpats ps
+ details (RecCon (HsRecFields { rec_dotdot = Nothing, rec_flds }))
+ = hs_lpats $ map (hfbRHS . unLoc) rec_flds
+ details (RecCon (HsRecFields { rec_dotdot = Just (L err_loc rec_dotdot), rec_flds }))
+ = [(err_loc, implicit_field_binders)]
+ ++ hs_lpats explicit_pats
+
+ where (explicit_pats, implicit_field_binders)
+ = rec_field_expl_impl rec_flds rec_dotdot
+
+ details (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2
+
+lHsRecFieldsImplicits :: [LHsRecField GhcRn (LPat GhcRn)]
+ -> RecFieldsDotDot
+ -> [ImplicitFieldBinders]
+lHsRecFieldsImplicits rec_flds rec_dotdot
+ = snd $ rec_field_expl_impl rec_flds rec_dotdot
+
+rec_field_expl_impl :: [LHsRecField GhcRn (LPat GhcRn)]
+ -> RecFieldsDotDot
+ -> ([LPat GhcRn], [ImplicitFieldBinders])
+rec_field_expl_impl rec_flds (RecFieldsDotDot { .. })
+ = ( map (hfbRHS . unLoc) explicit_binds
+ , map implicit_field_binders implicit_binds )
+ where (explicit_binds, implicit_binds) = splitAt unRecFieldsDotDot rec_flds
+ implicit_field_binders (L _ (HsFieldBind { hfbLHS = L _ fld, hfbRHS = rhs }))
+ = ImplicitFieldBinders
+ { implFlBndr_field = foExt fld
+ , implFlBndr_binders = collectPatBinders CollNoDictBinders rhs }
- (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld
- | (i, fld) <- [0..] `zip` rec_flds fs
- , let pat_explicit =
- maybe True ((i<) . unRecFieldsDotDot . unLoc)
- (rec_dotdot fs)]
- err_loc = maybe (getLocA n) getLoc (rec_dotdot fs)
- details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -397,7 +397,7 @@ rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside
-- Insert fake uses for variables introduced implicitly by
-- wildcards (#4404)
rec_uses = hsValBindsImplicits binds'
- implicit_uses = mkNameSet $ concatMap snd
+ implicit_uses = mkNameSet $ concatMap (concatMap implFlBndr_binders . snd)
$ rec_uses
; mapM_ (\(loc, ns) ->
checkUnusedRecordWildcard loc real_uses (Just ns))
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -83,7 +83,6 @@ import GHC.Types.Hint
import GHC.Types.Error
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.Warnings ( WarningTxt(..) )
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.TyCon
@@ -114,7 +113,6 @@ import Control.Monad
import Data.Either ( partitionEithers )
import Data.Function ( on )
import Data.List ( find, partition, groupBy, sortBy )
-import Data.Foldable ( for_ )
import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup as Semi
import System.IO.Unsafe ( unsafePerformIO )
@@ -182,7 +180,7 @@ deprecation warnings during renaming. At the moment, you don't get any
warning until you use the identifier further downstream. This would
require adjusting addUsedGRE so that during signature compilation,
we do not report deprecation warnings for LocalDef. See also
-Note [Handling of deprecations]
+Note [Handling of deprecations] in GHC.Rename.Utils
-}
newTopSrcBinder :: LocatedN RdrName -> RnM Name
@@ -1698,25 +1696,18 @@ lookupGreAvailRn rdr_name
* *
*********************************************************
-Note [Handling of deprecations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* We report deprecations at each *occurrence* of the deprecated thing
- (see #5867 and #4879)
-
-* We do not report deprecations for locally-defined names. For a
- start, we may be exporting a deprecated thing. Also we may use a
- deprecated thing in the defn of another deprecated things. We may
- even use a deprecated thing in the defn of a non-deprecated thing,
- when changing a module's interface.
-
-* We also report deprecations at export sites, but only for names
- deprecated with export deprecations (since those are not transitive as opposed
- to regular name deprecations and are only reported at the importing module)
-
-* addUsedGREs: we do not report deprecations for sub-binders:
- - the ".." completion for records
- - the ".." in an export item 'T(..)'
- - the things exported by a module export 'module M'
+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.
-}
addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM ()
@@ -1727,21 +1718,11 @@ addUsedDataCons rdr_env tycon
| dc <- tyConDataCons tycon
, Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ]
--- | Whether to report deprecation warnings when registering a used GRE
---
--- There is no option to only emit declaration warnings since everywhere
--- we emit the declaration warnings we also emit export warnings
--- (See Note [Handling of deprecations] for details)
-data DeprecationWarnings
- = NoDeprecationWarnings
- | ExportDeprecationWarnings
- | AllDeprecationWarnings
-
addUsedGRE :: DeprecationWarnings -> GlobalRdrElt -> RnM ()
-- Called for both local and imported things
-- Add usage *and* warn if deprecated
addUsedGRE warn_if_deprec gre
- = do { condWarnIfDeprecated warn_if_deprec [gre]
+ = do { warnIfDeprecated warn_if_deprec [gre]
; when (isImportedGRE gre) $ -- See Note [Using isImportedGRE in addUsedGRE]
do { env <- getGblEnv
-- Do not report the GREInfo (#23424)
@@ -1751,9 +1732,9 @@ addUsedGRE warn_if_deprec gre
addUsedGREs :: DeprecationWarnings -> [GlobalRdrElt] -> RnM ()
-- Record uses of any *imported* GREs
-- Used for recording used sub-bndrs
--- NB: no call to warnIfDeprecated; see Note [Handling of deprecations]
+-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] in GHC.Rename.Utils
addUsedGREs warn_if_deprec gres
- = do { condWarnIfDeprecated warn_if_deprec gres
+ = do { warnIfDeprecated warn_if_deprec gres
; unless (null imp_gres) $
do { env <- getGblEnv
-- Do not report the GREInfo (#23424)
@@ -1763,85 +1744,6 @@ addUsedGREs warn_if_deprec 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.
--}
-
-condWarnIfDeprecated :: DeprecationWarnings -> [GlobalRdrElt] -> RnM ()
-condWarnIfDeprecated NoDeprecationWarnings _ = return ()
-condWarnIfDeprecated opt gres = do
- this_mod <- getModule
- let external_gres
- = filterOut (nameIsLocalOrFrom this_mod . greName) gres
- mapM_ (\gre -> warnIfExportDeprecated gre >> maybeWarnDeclDepr gre) external_gres
- where
- maybeWarnDeclDepr = case opt of
- ExportDeprecationWarnings -> const $ return ()
- AllDeprecationWarnings -> warnIfDeclDeprecated
-
-warnIfDeclDeprecated :: GlobalRdrElt -> RnM ()
-warnIfDeclDeprecated gre@(GRE { gre_imp = iss })
- | Just imp_spec <- headMaybe iss
- = do { dflags <- getDynFlags
- ; when (wopt_any_custom dflags) $
- -- See Note [Handling of deprecations]
- do { iface <- loadInterfaceForName doc name
- ; case lookupImpDeclDeprec iface gre of
- Just deprText -> addDiagnostic $
- TcRnPragmaWarning
- PragmaWarningName
- { pwarn_occname = occ
- , pwarn_impmod = importSpecModule imp_spec
- , pwarn_declmod = definedMod }
- deprText
- Nothing -> return () } }
- | otherwise
- = return ()
- where
- occ = greOccName gre
- name = greName gre
- definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name)
- doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly"
-
-lookupImpDeclDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn)
-lookupImpDeclDeprec iface gre
- -- Bleat if the thing, or its parent, is warn'd
- = mi_decl_warn_fn (mi_final_exts iface) (greOccName gre) `mplus`
- case greParent gre of
- ParentIs p -> mi_decl_warn_fn (mi_final_exts iface) (nameOccName p)
- NoParent -> Nothing
-
-warnIfExportDeprecated :: GlobalRdrElt -> RnM ()
-warnIfExportDeprecated gre@(GRE { gre_imp = iss })
- = do { mod_warn_mbs <- mapBagM process_import_spec iss
- ; for_ (sequence mod_warn_mbs) $ mapM
- $ \(importing_mod, warn_txt) -> addDiagnostic $
- TcRnPragmaWarning
- PragmaWarningExport
- { pwarn_occname = occ
- , pwarn_impmod = importing_mod }
- warn_txt }
- where
- occ = greOccName gre
- name = greName gre
- doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly"
- process_import_spec :: ImportSpec -> RnM (Maybe (ModuleName, WarningTxt GhcRn))
- process_import_spec is = do
- let mod = is_mod $ is_decl is
- iface <- loadInterfaceForModule doc mod
- let mb_warn_txt = mi_export_warn_fn (mi_final_exts iface) name
- return $ (moduleName mod, ) <$> mb_warn_txt
-
{-
Note [Used names with interface not loaded]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -1452,7 +1452,7 @@ rnRecStmtsAndThen ctxt rnBody s cont
; let bound_names = collectLStmtsBinders CollNoDictBinders (map fst new_lhs_and_fv)
-- Fake uses of variables introduced implicitly (warning suppression, see #4404)
rec_uses = lStmtsImplicits (map fst new_lhs_and_fv)
- implicit_uses = mkNameSet $ concatMap snd $ rec_uses
+ implicit_uses = mkNameSet $ concatMap (concatMap implFlBndr_binders . snd) $ rec_uses
; bindLocalNamesFV bound_names $
addLocalFixities fix_env bound_names $ do
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -682,12 +682,15 @@ rnConPatAndThen mk con (RecCon rpats)
}
}
-checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()
+checkUnusedRecordWildcardCps :: SrcSpan
+ -> Maybe [ImplicitFieldBinders]
+ -> CpsRn ()
checkUnusedRecordWildcardCps loc dotdot_names =
CpsRn (\thing -> do
(r, fvs) <- thing ()
checkUnusedRecordWildcard loc fvs dotdot_names
return (r, fvs) )
+
--------------------
rnHsRecPatsAndThen :: NameMaker
-> LocatedN Name -- Constructor
@@ -698,7 +701,7 @@ rnHsRecPatsAndThen mk (L _ con)
= do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
hs_rec_fields
; flds' <- mapM rn_field (flds `zip` [1..])
- ; check_unused_wildcard (implicit_binders flds' <$> dd)
+ ; check_unused_wildcard (lHsRecFieldsImplicits flds' <$> unLoc <$> dd)
; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
where
mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n)
@@ -708,11 +711,6 @@ rnHsRecPatsAndThen mk (L _ con)
loc = maybe noSrcSpan getLoc dd
- -- Get the arguments of the implicit binders
- implicit_binders fs (unLoc -> RecFieldsDotDot n) = collectPatsBinders CollNoDictBinders implicit_pats
- where
- implicit_pats = map (hfbRHS . unLoc) (drop n fs)
-
-- Don't warn for let P{..} = ... in ...
check_unused_wildcard = case mk of
LetMk{} -> const (return ())
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -1,6 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
{-
@@ -16,6 +18,7 @@ module GHC.Rename.Utils (
warnUnusedMatches, warnUnusedTypePatterns,
warnUnusedTopBinds, warnUnusedLocalBinds,
warnForallIdentifier,
+ DeprecationWarnings(..), warnIfDeprecated,
checkUnusedRecordWildcard,
badQualBndrErr, typeAppErr, badFieldConErr,
wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genLHsApp,
@@ -56,17 +59,25 @@ import GHC.Types.SourceFile
import GHC.Types.SourceText ( SourceText(..), IntegralLit )
import GHC.Utils.Outputable
import GHC.Utils.Misc
+import GHC.Unit.Module.ModIface
+import GHC.Utils.Panic
import GHC.Types.Basic
import GHC.Data.List.SetOps ( removeDupsOn )
import GHC.Data.Maybe ( whenIsJust )
import GHC.Driver.DynFlags
import GHC.Data.FastString
+import GHC.Data.Bag ( mapBagM, headMaybe )
import Control.Monad
import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
+import GHC.Unit.Module
+import GHC.Unit.Module.Warnings ( WarningTxt(..) )
+import GHC.Iface.Load
import qualified GHC.LanguageExtensions as LangExt
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
+import Data.Foldable
+import Data.Maybe
{-
@@ -375,14 +386,17 @@ warnUnusedTopBinds gres
-- -Wredundant-record-wildcards
checkUnusedRecordWildcard :: SrcSpan
-> FreeVars
- -> Maybe [Name]
+ -> Maybe [ImplicitFieldBinders]
-> RnM ()
checkUnusedRecordWildcard _ _ Nothing = return ()
-checkUnusedRecordWildcard loc _ (Just []) =
- -- Add a new warning if the .. pattern binds no variables
- setSrcSpan loc $ warnRedundantRecordWildcard
-checkUnusedRecordWildcard loc fvs (Just dotdot_names) =
- setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs
+checkUnusedRecordWildcard loc fvs (Just dotdot_fields_binders)
+ = setSrcSpan loc $ case concatMap implFlBndr_binders dotdot_fields_binders of
+ -- Add a new warning if the .. pattern binds no variables
+ [] -> warnRedundantRecordWildcard
+ dotdot_names
+ -> do
+ warnUnusedRecordWildcard dotdot_names fvs
+ deprecateUsedRecordWildcard dotdot_fields_binders fvs
-- | Produce a warning when the `..` pattern binds no new
@@ -415,6 +429,33 @@ warnUnusedRecordWildcard ns used_names = do
traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)
warnIf (null used) (TcRnUnusedRecordWildcard ns)
+-- | Emit a deprecation message whenever one of the implicit record wild
+-- card field binders was used in FreeVars.
+--
+-- @
+-- module A where
+-- data P = P { x :: Int, y :: Int }
+-- {-# DEPRECATED x, y "depr msg" #-}
+--
+-- module B where
+-- import A
+-- foo (P{..}) = x
+-- @
+--
+-- Even though both `x` and `y` have deprecations, only `x`
+-- will be deprecated since only its implicit variable is used in the RHS.
+deprecateUsedRecordWildcard :: [ImplicitFieldBinders]
+ -> FreeVars -> RnM ()
+deprecateUsedRecordWildcard dotdot_fields_binders fvs
+ = mapM_ depr_field_binders dotdot_fields_binders
+ where
+ depr_field_binders (ImplicitFieldBinders {..})
+ = when (mkFVs implFlBndr_binders `intersectsFVs` fvs) $ do
+ env <- getGlobalRdrEnv
+ let gre = fromJust $ lookupGRE_Name env implFlBndr_field
+ -- Must be in the env since it was instantiated
+ -- in the implicit binders
+ warnIfDeprecated AllDeprecationWarnings [gre]
warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
@@ -434,6 +475,109 @@ warnForallIdentifier (L l rdr_name@(Unqual occ))
where isKw = (occNameFS occ ==)
warnForallIdentifier _ = return ()
+{-
+************************************************************************
+* *
+\subsection{Custom deprecations utility functions}
+* *
+************************************************************************
+
+Note [Handling of deprecations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* We report deprecations at each *occurrence* of the deprecated thing
+ (see #5867 and #4879)
+
+* We do not report deprecations for locally-defined names. For a
+ start, we may be exporting a deprecated thing. Also we may use a
+ deprecated thing in the defn of another deprecated things. We may
+ even use a deprecated thing in the defn of a non-deprecated thing,
+ when changing a module's interface.
+
+* We also report deprecations at export sites, but only for names
+ deprecated with export deprecations (since those are not transitive as opposed
+ to regular name deprecations and are only reported at the importing module)
+
+* addUsedGREs: we do not report deprecations for sub-binders:
+ - the ".." completion for records
+ - the ".." in an export item 'T(..)'
+ - the things exported by a module export 'module M'
+-}
+
+-- | Whether to report deprecation warnings when registering a used GRE
+--
+-- There is no option to only emit declaration warnings since everywhere
+-- we emit the declaration warnings we also emit export warnings
+-- (See Note [Handling of deprecations] for details)
+data DeprecationWarnings
+ = NoDeprecationWarnings
+ | ExportDeprecationWarnings
+ | AllDeprecationWarnings
+
+warnIfDeprecated :: DeprecationWarnings -> [GlobalRdrElt] -> RnM ()
+warnIfDeprecated NoDeprecationWarnings _ = return ()
+warnIfDeprecated opt gres = do
+ this_mod <- getModule
+ let external_gres
+ = filterOut (nameIsLocalOrFrom this_mod . greName) gres
+ mapM_ (\gre -> warnIfExportDeprecated gre >> maybeWarnDeclDepr gre) external_gres
+ where
+ maybeWarnDeclDepr = case opt of
+ ExportDeprecationWarnings -> const $ return ()
+ AllDeprecationWarnings -> warnIfDeclDeprecated
+
+warnIfDeclDeprecated :: GlobalRdrElt -> RnM ()
+warnIfDeclDeprecated gre@(GRE { gre_imp = iss })
+ | Just imp_spec <- headMaybe iss
+ = do { dflags <- getDynFlags
+ ; when (wopt_any_custom dflags) $
+ -- See Note [Handling of deprecations]
+ do { iface <- loadInterfaceForName doc name
+ ; case lookupImpDeclDeprec iface gre of
+ Just deprText -> addDiagnostic $
+ TcRnPragmaWarning
+ PragmaWarningName
+ { pwarn_occname = occ
+ , pwarn_impmod = importSpecModule imp_spec
+ , pwarn_declmod = definedMod }
+ deprText
+ Nothing -> return () } }
+ | otherwise
+ = return ()
+ where
+ occ = greOccName gre
+ name = greName gre
+ definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name)
+ doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly"
+
+lookupImpDeclDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn)
+lookupImpDeclDeprec iface gre
+ -- Bleat if the thing, or its parent, is warn'd
+ = mi_decl_warn_fn (mi_final_exts iface) (greOccName gre) `mplus`
+ case greParent gre of
+ ParentIs p -> mi_decl_warn_fn (mi_final_exts iface) (nameOccName p)
+ NoParent -> Nothing
+
+warnIfExportDeprecated :: GlobalRdrElt -> RnM ()
+warnIfExportDeprecated gre@(GRE { gre_imp = iss })
+ = do { mod_warn_mbs <- mapBagM process_import_spec iss
+ ; for_ (sequence mod_warn_mbs) $ mapM
+ $ \(importing_mod, warn_txt) -> addDiagnostic $
+ TcRnPragmaWarning
+ PragmaWarningExport
+ { pwarn_occname = occ
+ , pwarn_impmod = importing_mod }
+ warn_txt }
+ where
+ occ = greOccName gre
+ name = greName gre
+ doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly"
+ process_import_spec :: ImportSpec -> RnM (Maybe (ModuleName, WarningTxt GhcRn))
+ process_import_spec is = do
+ let mod = is_mod $ is_decl is
+ iface <- loadInterfaceForModule doc mod
+ let mb_warn_txt = mi_export_warn_fn (mi_final_exts iface) name
+ return $ (moduleName mod, ) <$> mb_warn_txt
+
-------------------------
-- Helpers
warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -54,7 +54,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, DeprecationWarnings(..) )
+import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
import GHC.Tc.Gen.Match
=====================================
compiler/GHC/Types/Name/Set.hs
=====================================
@@ -22,7 +22,7 @@ module GHC.Types.Name.Set (
-- ** Manipulating sets of free variables
isEmptyFVs, emptyFVs, plusFVs, plusFV,
mkFVs, addOneFV, unitFV, delFV, delFVs,
- intersectFVs,
+ intersectFVs, intersectsFVs,
-- * Defs and uses
Defs, Uses, DefUse, DefUses,
@@ -127,6 +127,7 @@ mkFVs :: [Name] -> FreeVars
delFV :: Name -> FreeVars -> FreeVars
delFVs :: [Name] -> FreeVars -> FreeVars
intersectFVs :: FreeVars -> FreeVars -> FreeVars
+intersectsFVs :: FreeVars -> FreeVars -> Bool
isEmptyFVs :: NameSet -> Bool
isEmptyFVs = isEmptyNameSet
@@ -139,6 +140,7 @@ unitFV = unitNameSet
delFV n s = delFromNameSet s n
delFVs ns s = delListFromNameSet s ns
intersectFVs = intersectNameSet
+intersectsFVs = intersectsNameSet
{-
************************************************************************
=====================================
libraries/ghc-prim/ghc-prim.cabal
=====================================
@@ -0,0 +1,108 @@
+cabal-version: 2.2
+name: ghc-prim
+version: 0.10.0
+-- NOTE: Don't forget to update ./changelog.md
+license: BSD-3-Clause
+license-file: LICENSE
+category: GHC
+maintainer: libraries at haskell.org
+bug-reports: https://gitlab.haskell.org/ghc/ghc/issues/new
+synopsis: GHC primitives
+build-type: Custom
+description:
+ This package contains the primitive types and operations supplied by GHC.
+
+ It is an internal package, only for the use of GHC developers.
+ GHC users should not use it! If you do use it then expect
+ breaking changes at any time without warning. You should prefer
+ to import @GHC.Exts@ from the @base@ package instead.
+
+extra-source-files: changelog.md
+
+source-repository head
+ type: git
+ location: https://gitlab.haskell.org/ghc/ghc.git
+ subdir: libraries/ghc-prim
+
+custom-setup
+ setup-depends: base >= 4 && < 5, process, filepath, directory, Cabal >= 1.23 && < 3.9
+
+flag need-atomic
+ default: False
+
+Library
+ default-language: Haskell2010
+ other-extensions:
+ BangPatterns
+ CPP
+ DeriveGeneric
+ MagicHash
+ MultiParamTypeClasses
+ NoImplicitPrelude
+ StandaloneDeriving
+ Trustworthy
+ TypeFamilies
+ UnboxedTuples
+ UnliftedFFITypes
+
+ build-depends: rts == 1.0.*
+
+ exposed-modules:
+ GHC.CString
+ GHC.Classes
+ GHC.Debug
+ GHC.Magic
+ GHC.Magic.Dict
+ GHC.Prim.Ext
+ GHC.Prim.Panic
+ GHC.Prim.Exception
+ GHC.Prim.PtrEq
+ GHC.PrimopWrappers
+ GHC.Tuple
+ GHC.Tuple.Prim
+ GHC.Types
+
+ virtual-modules:
+ GHC.Prim
+
+ -- OS Specific
+ if os(windows)
+ -- Windows requires some extra libraries for linking because the RTS
+ -- is no longer re-exporting them (see #11223)
+ -- ucrt: standard C library. The RTS will automatically include this,
+ -- but is added for completeness.
+ -- mingwex: provides GNU POSIX extensions that aren't provided by ucrt.
+ -- mingw32: Unfortunately required because of a resource leak between
+ -- mingwex and mingw32. the __math_err symbol is defined in
+ -- mingw32 which is required by mingwex.
+ -- user32: provides access to apis to modify user components (UI etc)
+ -- on Windows. Required because of mingw32.
+ extra-libraries: user32, mingw32, mingwex, ucrt
+
+ if os(linux)
+ -- we need libm, but for musl and other's we might need libc, as libm
+ -- is just an empty shell.
+ extra-libraries: c, m
+
+ if flag(need-atomic)
+ -- for 64-bit atomic ops on armel (#20549)
+ extra-libraries: atomic
+
+ if !os(ghcjs)
+ c-sources:
+ cbits/atomic.c
+ cbits/bswap.c
+ cbits/bitrev.c
+ cbits/clz.c
+ cbits/ctz.c
+ cbits/debug.c
+ cbits/longlong.c
+ cbits/mulIntMayOflo.c
+ cbits/pdep.c
+ cbits/pext.c
+ cbits/popcnt.c
+ cbits/word2float.c
+
+ -- We need to set the unit ID to ghc-prim (without a version number)
+ -- as it's magic.
+ ghc-options: -this-unit-id ghc-prim
=====================================
testsuite/tests/rename/should_compile/RecordWildCardDeprecation.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE RecordWildCards #-}
+module RecordWildCardDeprecation where
+
+import RecordWildCardDeprecation_aux
+
+f (Foo { .. }) = let a = x in a
+
+g (Foo { .. }) = let a = y in a
+
+h (Foo { .. }) = let a = z in a
\ No newline at end of file
=====================================
testsuite/tests/rename/should_compile/RecordWildCardDeprecation.stderr
=====================================
@@ -0,0 +1,12 @@
+[1 of 2] Compiling RecordWildCardDeprecation_aux ( RecordWildCardDeprecation_aux.hs, RecordWildCardDeprecation_aux.o )
+[2 of 2] Compiling RecordWildCardDeprecation ( RecordWildCardDeprecation.hs, RecordWildCardDeprecation.o )
+
+RecordWildCardDeprecation.hs:6:10: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of record field of Foo ‘x’
+ (imported from RecordWildCardDeprecation_aux):
+ Deprecated: "name depr"
+
+RecordWildCardDeprecation.hs:8:10: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of record field of Foo ‘y’
+ (imported from RecordWildCardDeprecation_aux):
+ Deprecated: "export depr"
=====================================
testsuite/tests/rename/should_compile/RecordWildCardDeprecation_aux.hs
=====================================
@@ -0,0 +1,5 @@
+module RecordWildCardDeprecation_aux(Foo(Foo, x, z), {-# DEPRECATED "export depr" #-} Foo(y)) where
+
+data Foo = Foo { x :: Int, y :: Bool, z :: Char }
+
+{-# DEPRECATED x "name depr" #-}
\ No newline at end of file
=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -222,3 +222,4 @@ test('ExportWarnings4', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_a
test('ExportWarnings5', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_aux.hs']), multimod_compile, ['ExportWarnings5', '-v0 -Wno-duplicate-exports -Wx-custom'])
test('ExportWarnings6', normal, compile, ['-Wincomplete-export-warnings'])
test('T22478a', req_th, compile, [''])
+test('RecordWildCardDeprecation', normal, multimod_compile, ['RecordWildCardDeprecation', '-Wno-duplicate-exports'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/524c60c8cd8ad63cf1dba01ef2ceeff144751db7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/524c60c8cd8ad63cf1dba01ef2ceeff144751db7
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/20230814/60fec807/attachment-0001.html>
More information about the ghc-commits
mailing list