From d2bedffdc07b766f01dfcd4fc73a3859305814f3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bart=C5=82omiej=20Cie=C5=9Blar?= <bcieslar2001@gmail.com>
Date: Fri, 30 Jun 2023 13:57:26 +0200
Subject: [PATCH] Implementation of the Deprecated Instances proposal #575
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This commit implements the ability to deprecate certain instances,
which causes the compiler to emit the desired deprecation message
whenever they are instantiated. For example:
module A where
class C t where
instance {-# DEPRECATED "dont use" #-} C Int where
module B where
import A
f :: C t => t
f = undefined
g :: Int
g = f -- "dont use" emitted here
The implementation is as follows:
- In the parser, we parse deprecations/warnings attached to instances:
instance {-# DEPRECATED "msg" #-} Show X
deriving instance {-# WARNING "msg2" #-} Eq Y
(Note that non-standalone deriving instance declarations do not support
this mechanism.)
- We store the resulting warning message in `ClsInstDecl` (respectively, `DerivDecl`).
In `GHC.Tc.TyCl.Instance.tcClsInstDecl` (respectively, `GHC.Tc.Deriv.Utils.newDerivClsInst`),
we pass on that information to `ClsInst` (and eventually store it in `IfaceClsInst` too).
- Finally, when we solve a constraint using such an instance, in
`GHC.Tc.Instance.Class.matchInstEnv`, we emit the appropriate warning
that was stored in `ClsInst`.
Note that we only emit a warning when the instance is used in a different module
than it is defined, which keeps the behaviour in line with the deprecation of
top-level identifiers.
Signed-off-by: Bartłomiej Cieślar <bcieslar2001@gmail.com>
---
compiler/GHC/Core/InstEnv.hs | 52 ++++++++++----
compiler/GHC/Hs.hs | 4 +-
compiler/GHC/Hs/Decls.hs | 70 ++++++++++++++++---
compiler/GHC/Hs/ImpExp.hs | 24 +++----
compiler/GHC/Iface/Make.hs | 7 +-
compiler/GHC/Iface/Syntax.hs | 17 +++--
compiler/GHC/IfaceToCore.hs | 5 +-
compiler/GHC/Parser.y | 65 ++++++++---------
compiler/GHC/Parser/PostProcess.hs | 2 +-
compiler/GHC/Rename/Env.hs | 23 +++---
compiler/GHC/Rename/Module.hs | 15 ++--
compiler/GHC/Rename/Names.hs | 11 ++-
compiler/GHC/Tc/Deriv.hs | 22 ++++--
compiler/GHC/Tc/Deriv/Utils.hs | 12 +++-
compiler/GHC/Tc/Errors/Ppr.hs | 29 +++++---
compiler/GHC/Tc/Errors/Types.hs | 24 +++++--
compiler/GHC/Tc/Gen/Export.hs | 9 +--
compiler/GHC/Tc/Instance/Class.hs | 15 ++--
compiler/GHC/Tc/Solver/Dict.hs | 59 +++++++++++++++-
compiler/GHC/Tc/TyCl/Instance.hs | 6 +-
compiler/GHC/Tc/Types/Origin.hs | 6 +-
compiler/GHC/Tc/Utils/Instantiate.hs | 7 +-
compiler/GHC/ThToHs.hs | 4 +-
compiler/GHC/Unit/Module/Warnings.hs | 6 ++
docs/users_guide/exts/pragmas.rst | 60 +++++++++++-----
.../should_compile_flag_haddock/T17544.stderr | 20 ++++--
.../should_compile/DumpRenamedAst.stderr | 2 +-
testsuite/tests/printer/Makefile | 5 ++
testsuite/tests/printer/PprInstanceWarn.hs | 11 +++
testsuite/tests/printer/all.T | 1 +
.../should_compile/InstanceWarnings.hs | 13 ++++
.../should_compile/InstanceWarnings.stderr | 29 ++++++++
.../should_compile/InstanceWarnings_aux.hs | 14 ++++
.../tests/typecheck/should_compile/all.T | 1 +
utils/check-exact/ExactPrint.hs | 25 ++++---
35 files changed, 486 insertions(+), 189 deletions(-)
create mode 100644 testsuite/tests/printer/PprInstanceWarn.hs
create mode 100644 testsuite/tests/typecheck/should_compile/InstanceWarnings.hs
create mode 100644 testsuite/tests/typecheck/should_compile/InstanceWarnings.stderr
create mode 100644 testsuite/tests/typecheck/should_compile/InstanceWarnings_aux.hs
diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs
index 70681c84a4ee..e8d1f85b59d8 100644
--- a/compiler/GHC/Core/InstEnv.hs
+++ b/compiler/GHC/Core/InstEnv.hs
@@ -13,8 +13,8 @@ module GHC.Core.InstEnv (
DFunId, InstMatch, ClsInstLookupResult,
Coherence(..), PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers,
OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
- ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,
- instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst,
+ ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprDFunId, pprInstances,
+ instanceWarning, instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst,
instanceDFunId, updateClsInstDFuns, updateClsInstDFun,
fuzzyClsInstCmp, orphNamesOfClsInst,
@@ -42,8 +42,10 @@ import GHC.Core.RoughMap
import GHC.Core.Class
import GHC.Core.Unify
import GHC.Core.FVs( orphNamesOfTypes, orphNamesOfType )
+import GHC.Hs.Extension
import GHC.Unit.Module.Env
+import GHC.Unit.Module.Warnings
import GHC.Unit.Types
import GHC.Types.Var
import GHC.Types.Unique.DSet
@@ -108,6 +110,10 @@ data ClsInst
, is_flag :: OverlapFlag -- See detailed comments with
-- the decl of BasicTypes.OverlapFlag
, is_orphan :: IsOrphan
+ , is_warn :: Maybe (WarningTxt GhcRn)
+ -- Warning emitted when the instance is used
+ -- See Note [Implementation of deprecated instances]
+ -- in GHC.Tc.Solver.Dict
}
deriving Data
@@ -217,6 +223,16 @@ instance NamedThing ClsInst where
instance Outputable ClsInst where
ppr = pprInstance
+pprDFunId :: DFunId -> SDoc
+-- Prints the analogous information to `pprInstance`
+-- but with just the DFunId
+pprDFunId dfun
+ = hang dfun_header
+ 2 (vcat [ text "--" <+> pprDefinedAt (getName dfun)
+ , whenPprDebug (ppr dfun) ])
+ where
+ dfun_header = ppr_overlap_dfun_hdr empty dfun
+
pprInstance :: ClsInst -> SDoc
-- Prints the ClsInst as an instance declaration
pprInstance ispec
@@ -228,11 +244,18 @@ pprInstance ispec
pprInstanceHdr :: ClsInst -> SDoc
-- Prints the ClsInst as an instance declaration
pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })
- = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun)
+ = ppr_overlap_dfun_hdr (ppr flag) dfun
+
+ppr_overlap_dfun_hdr :: SDoc -> DFunId -> SDoc
+ppr_overlap_dfun_hdr flag_sdoc dfun
+ = text "instance" <+> flag_sdoc <+> pprSigmaType (idType dfun)
pprInstances :: [ClsInst] -> SDoc
pprInstances ispecs = vcat (map pprInstance ispecs)
+instanceWarning :: ClsInst -> Maybe (WarningTxt GhcRn)
+instanceWarning = is_warn
+
instanceHead :: ClsInst -> ([TyVar], Class, [Type])
-- Returns the head, using the fresh tyvars from the ClsInst
instanceHead (ClsInst { is_tvs = tvs, is_cls = cls, is_tys = tys })
@@ -260,17 +283,18 @@ instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec))
mkLocalClsInst :: DFunId -> OverlapFlag
-> [TyVar] -> Class -> [Type]
+ -> Maybe (WarningTxt GhcRn)
-> ClsInst
-- Used for local instances, where we can safely pull on the DFunId.
-- Consider using newClsInst instead; this will also warn if
-- the instance is an orphan.
-mkLocalClsInst dfun oflag tvs cls tys
+mkLocalClsInst dfun oflag tvs cls tys warn
= ClsInst { is_flag = oflag, is_dfun = dfun
, is_tvs = tvs
, is_dfun_name = dfun_name
, is_cls = cls, is_cls_nm = cls_name
, is_tys = tys, is_tcs = RM_KnownTc cls_name : roughMatchTcs tys
- , is_orphan = orph
+ , is_orphan = orph, is_warn = warn
}
where
cls_name = className cls
@@ -301,24 +325,26 @@ mkLocalClsInst dfun oflag tvs cls tys
choose_one nss = chooseOrphanAnchor (unionNameSets nss)
-mkImportedClsInst :: Name -- ^ the name of the class
- -> [RoughMatchTc] -- ^ the rough match signature of the instance
- -> Name -- ^ the 'Name' of the dictionary binding
- -> DFunId -- ^ the 'Id' of the dictionary.
- -> OverlapFlag -- ^ may this instance overlap?
- -> IsOrphan -- ^ is this instance an orphan?
+mkImportedClsInst :: Name -- ^ the name of the class
+ -> [RoughMatchTc] -- ^ the rough match signature of the instance
+ -> Name -- ^ the 'Name' of the dictionary binding
+ -> DFunId -- ^ the 'Id' of the dictionary.
+ -> OverlapFlag -- ^ may this instance overlap?
+ -> IsOrphan -- ^ is this instance an orphan?
+ -> Maybe (WarningTxt GhcRn) -- ^ warning emitted when solved
-> ClsInst
-- Used for imported instances, where we get the rough-match stuff
-- from the interface file
-- The bound tyvars of the dfun are guaranteed fresh, because
-- the dfun has been typechecked out of the same interface file
-mkImportedClsInst cls_nm mb_tcs dfun_name dfun oflag orphan
+mkImportedClsInst cls_nm mb_tcs dfun_name dfun oflag orphan warn
= ClsInst { is_flag = oflag, is_dfun = dfun
, is_tvs = tvs, is_tys = tys
, is_dfun_name = dfun_name
, is_cls_nm = cls_nm, is_cls = cls
, is_tcs = RM_KnownTc cls_nm : mb_tcs
- , is_orphan = orphan }
+ , is_orphan = orphan
+ , is_warn = warn }
where
(tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs
index 9ec3215dbd90..0125fb79a321 100644
--- a/compiler/GHC/Hs.hs
+++ b/compiler/GHC/Hs.hs
@@ -59,7 +59,7 @@ import GHC.Hs.Instances () -- For Data instances
import GHC.Utils.Outputable
import GHC.Types.Fixity ( Fixity )
import GHC.Types.SrcLoc
-import GHC.Unit.Module.Warnings ( WarningTxt )
+import GHC.Unit.Module.Warnings
-- libraries:
import Data.Data hiding ( Fixity )
@@ -71,7 +71,7 @@ data XModulePs
hsmodLayout :: LayoutInfo GhcPs,
-- ^ Layout info for the module.
-- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo.
- hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)),
+ hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs),
-- ^ reason\/explanation for warning/deprecation of this module
--
-- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 705e9fcaf0fa..4cdae1d29466 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -10,6 +10,7 @@
-- in module Language.Haskell.Syntax.Extension
{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable
+{-# LANGUAGE InstanceSigs #-}
{-
(c) The University of Glasgow 2006
@@ -125,7 +126,7 @@ import GHC.Types.SrcLoc
import GHC.Types.SourceText
import GHC.Core.Type
import GHC.Types.ForeignCall
-import GHC.Unit.Module.Warnings (WarningTxt(..))
+import GHC.Unit.Module.Warnings
import GHC.Data.Bag
import GHC.Data.Maybe
@@ -797,8 +798,17 @@ type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA
----------------- Class instances -------------
-type instance XCClsInstDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey) -- TODO:AZ:tidy up
-type instance XCClsInstDecl GhcRn = NoExtField
+type instance XCClsInstDecl GhcPs = ( Maybe (LWarningTxt GhcPs)
+ -- The warning of the deprecated instance
+ -- See Note [Implementation of deprecated instances]
+ -- in GHC.Tc.Solver.Dict
+ , EpAnn [AddEpAnn]
+ , AnnSortKey) -- For sorting the additional annotations
+ -- TODO:AZ:tidy up
+type instance XCClsInstDecl GhcRn = Maybe (LWarningTxt GhcRn)
+ -- The warning of the deprecated instance
+ -- See Note [Implementation of deprecated instances]
+ -- in GHC.Tc.Solver.Dict
type instance XCClsInstDecl GhcTc = NoExtField
type instance XXClsInstDecl (GhcPass _) = DataConCantHappen
@@ -815,6 +825,19 @@ type instance XTyFamInstD GhcTc = NoExtField
type instance XXInstDecl (GhcPass _) = DataConCantHappen
+cidDeprecation :: forall p. IsPass p
+ => ClsInstDecl (GhcPass p)
+ -> Maybe (WarningTxt (GhcPass p))
+cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)
+ where
+ decl_deprecation :: GhcPass p -> ClsInstDecl (GhcPass p)
+ -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+ decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _, _) } )
+ = depr
+ decl_deprecation GhcRn (ClsInstDecl{ cid_ext = depr })
+ = depr
+ decl_deprecation _ _ = Nothing
+
instance OutputableBndrId p
=> Outputable (TyFamInstDecl (GhcPass p)) where
ppr = pprTyFamInstDecl TopLevel
@@ -878,10 +901,10 @@ pprHsFamInstLHS thing bndrs typats fixity mb_ctxt
instance OutputableBndrId p
=> Outputable (ClsInstDecl (GhcPass p)) where
- ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
- , cid_sigs = sigs, cid_tyfam_insts = ats
- , cid_overlap_mode = mbOverlap
- , cid_datafam_insts = adts })
+ ppr (cid@ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
+ , cid_sigs = sigs, cid_tyfam_insts = ats
+ , cid_overlap_mode = mbOverlap
+ , cid_datafam_insts = adts })
| null sigs, null ats, null adts, isEmptyBag binds -- No "where" part
= top_matter
@@ -892,8 +915,9 @@ instance OutputableBndrId p
map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
pprLHsBindsForUser binds sigs ]
where
- top_matter = text "instance" <+> ppOverlapPragma mbOverlap
- <+> ppr inst_ty
+ top_matter = text "instance" <+> maybe empty ppr (cidDeprecation cid)
+ <+> ppOverlapPragma mbOverlap
+ <+> ppr inst_ty
ppDerivStrategy :: OutputableBndrId p
=> Maybe (LDerivStrategy (GhcPass p)) -> SDoc
@@ -958,19 +982,43 @@ anyLConIsGadt xs = case toList xs of
************************************************************************
-}
-type instance XCDerivDecl (GhcPass _) = EpAnn [AddEpAnn]
+type instance XCDerivDecl GhcPs = ( Maybe (LWarningTxt GhcPs)
+ -- The warning of the deprecated derivation
+ -- See Note [Implementation of deprecated instances]
+ -- in GHC.Tc.Solver.Dict
+ , EpAnn [AddEpAnn] )
+type instance XCDerivDecl GhcRn = ( Maybe (LWarningTxt GhcRn)
+ -- The warning of the deprecated derivation
+ -- See Note [Implementation of deprecated instances]
+ -- in GHC.Tc.Solver.Dict
+ , EpAnn [AddEpAnn] )
+type instance XCDerivDecl GhcTc = EpAnn [AddEpAnn]
type instance XXDerivDecl (GhcPass _) = DataConCantHappen
+derivDeprecation :: forall p. IsPass p
+ => DerivDecl (GhcPass p)
+ -> Maybe (WarningTxt (GhcPass p))
+derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)
+ where
+ decl_deprecation :: GhcPass p -> DerivDecl (GhcPass p)
+ -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+ decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) })
+ = depr
+ decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) })
+ = depr
+ decl_deprecation _ _ = Nothing
+
type instance Anno OverlapMode = SrcSpanAnnP
instance OutputableBndrId p
=> Outputable (DerivDecl (GhcPass p)) where
- ppr (DerivDecl { deriv_type = ty
+ ppr (deriv@DerivDecl { deriv_type = ty
, deriv_strategy = ds
, deriv_overlap_mode = o })
= hsep [ text "deriving"
, ppDerivStrategy ds
, text "instance"
+ , maybe empty ppr (derivDeprecation deriv)
, ppOverlapPragma o
, ppr ty ]
diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs
index 5e25893cb962..7e61998048e5 100644
--- a/compiler/GHC/Hs/ImpExp.hs
+++ b/compiler/GHC/Hs/ImpExp.hs
@@ -38,7 +38,7 @@ import GHC.Hs.Extension
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Unit.Module.Warnings (WarningTxt)
+import GHC.Unit.Module.Warnings
import Data.Data
import Data.Maybe
@@ -203,36 +203,36 @@ type instance Anno (IE (GhcPass p)) = SrcSpanAnnA
-- The additional field of type 'Maybe (WarningTxt pass)' holds information
-- about export deprecation annotations and is thus set to Nothing when `IE`
-- is used in an import list (since export deprecation can only be used in exports)
-type instance XIEVar GhcPs = Maybe (LocatedP (WarningTxt GhcPs))
-type instance XIEVar GhcRn = Maybe (LocatedP (WarningTxt GhcRn))
+type instance XIEVar GhcPs = Maybe (LWarningTxt GhcPs)
+type instance XIEVar GhcRn = Maybe (LWarningTxt GhcRn)
type instance XIEVar GhcTc = NoExtField
-- The additional field of type 'Maybe (WarningTxt pass)' holds information
-- about export deprecation annotations and is thus set to Nothing when `IE`
-- is used in an import list (since export deprecation can only be used in exports)
-type instance XIEThingAbs GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])
-type instance XIEThingAbs GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn])
+type instance XIEThingAbs GhcPs = (Maybe (LWarningTxt GhcPs), EpAnn [AddEpAnn])
+type instance XIEThingAbs GhcRn = (Maybe (LWarningTxt GhcRn), EpAnn [AddEpAnn])
type instance XIEThingAbs GhcTc = EpAnn [AddEpAnn]
-- The additional field of type 'Maybe (WarningTxt pass)' holds information
-- about export deprecation annotations and is thus set to Nothing when `IE`
-- is used in an import list (since export deprecation can only be used in exports)
-type instance XIEThingAll GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])
-type instance XIEThingAll GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn])
+type instance XIEThingAll GhcPs = (Maybe (LWarningTxt GhcPs), EpAnn [AddEpAnn])
+type instance XIEThingAll GhcRn = (Maybe (LWarningTxt GhcRn), EpAnn [AddEpAnn])
type instance XIEThingAll GhcTc = EpAnn [AddEpAnn]
-- The additional field of type 'Maybe (WarningTxt pass)' holds information
-- about export deprecation annotations and is thus set to Nothing when `IE`
-- is used in an import list (since export deprecation can only be used in exports)
-type instance XIEThingWith GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])
-type instance XIEThingWith GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn])
+type instance XIEThingWith GhcPs = (Maybe (LWarningTxt GhcPs), EpAnn [AddEpAnn])
+type instance XIEThingWith GhcRn = (Maybe (LWarningTxt GhcRn), EpAnn [AddEpAnn])
type instance XIEThingWith GhcTc = EpAnn [AddEpAnn]
-- The additional field of type 'Maybe (WarningTxt pass)' holds information
-- about export deprecation annotations and is thus set to Nothing when `IE`
-- is used in an import list (since export deprecation can only be used in exports)
-type instance XIEModuleContents GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])
-type instance XIEModuleContents GhcRn = Maybe (LocatedP (WarningTxt GhcRn))
+type instance XIEModuleContents GhcPs = (Maybe (LWarningTxt GhcPs), EpAnn [AddEpAnn])
+type instance XIEModuleContents GhcRn = Maybe (LWarningTxt GhcRn)
type instance XIEModuleContents GhcTc = NoExtField
type instance XIEGroup (GhcPass _) = NoExtField
@@ -264,7 +264,7 @@ ieNames (IEDocNamed {}) = []
ieDeprecation :: forall p. IsPass p => IE (GhcPass p) -> Maybe (WarningTxt (GhcPass p))
ieDeprecation = fmap unLoc . ie_deprecation (ghcPass @p)
where
- ie_deprecation :: GhcPass p -> IE (GhcPass p) -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+ ie_deprecation :: GhcPass p -> IE (GhcPass p) -> Maybe (LWarningTxt (GhcPass p))
ie_deprecation GhcPs (IEVar xie _) = xie
ie_deprecation GhcPs (IEThingAbs (xie, _) _) = xie
ie_deprecation GhcPs (IEThingAll (xie, _) _) = xie
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 2dc05841f78d..d144ecf23875 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -14,6 +14,7 @@ module GHC.Iface.Make
, mkFullIface
, mkIfaceTc
, mkIfaceExports
+ , toIfaceWarningTxt
)
where
@@ -367,7 +368,8 @@ instanceToIfaceInst :: ClsInst -> IfaceClsInst
instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
, is_cls_nm = cls_name, is_cls = cls
, is_tcs = rough_tcs
- , is_orphan = orph })
+ , is_orphan = orph
+ , is_warn = warn })
= assert (cls_name == className cls) $
IfaceClsInst { ifDFun = idName dfun_id
, ifOFlag = oflag
@@ -375,7 +377,8 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
, ifInstTys = ifaceRoughMatchTcs $ tail rough_tcs
-- N.B. Drop the class name from the rough match template
-- It is put back by GHC.Core.InstEnv.mkImportedClsInst
- , ifInstOrph = orph }
+ , ifInstOrph = orph
+ , ifInstWarn = fmap toIfaceWarningTxt warn }
--------------------------
famInstToIfaceFamInst :: FamInst -> IfaceFamInst
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 60d2274d69e2..a2a955bf46a3 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -35,6 +35,7 @@ module GHC.Iface.Syntax (
ifaceDeclFingerprints,
fromIfaceBooleanFormula,
fromIfaceWarnings,
+ fromIfaceWarningTxt,
-- Free Names
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
@@ -315,7 +316,11 @@ data IfaceClsInst
ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst
ifDFun :: IfExtName, -- The dfun
ifOFlag :: OverlapFlag, -- Overlap flag
- ifInstOrph :: IsOrphan } -- See Note [Orphans] in GHC.Core.InstEnv
+ ifInstOrph :: IsOrphan, -- See Note [Orphans] in GHC.Core.InstEnv
+ ifInstWarn :: Maybe IfaceWarningTxt }
+ -- Warning emitted when the instance is used
+ -- See Note [Implementation of deprecated instances]
+ -- in GHC.Tc.Solver.Dict
-- There's always a separate IfaceDecl for the DFun, which gives
-- its IdInfo with its full type and version number.
-- The instance declarations taken together have a version number,
@@ -2269,19 +2274,21 @@ instance Binary IfaceSrcBang where
return (IfSrcBang a1 a2)
instance Binary IfaceClsInst where
- put_ bh (IfaceClsInst cls tys dfun flag orph) = do
+ put_ bh (IfaceClsInst cls tys dfun flag orph warn) = do
put_ bh cls
put_ bh tys
put_ bh dfun
put_ bh flag
put_ bh orph
+ put_ bh warn
get bh = do
cls <- get bh
tys <- get bh
dfun <- get bh
flag <- get bh
orph <- get bh
- return (IfaceClsInst cls tys dfun flag orph)
+ warn <- get bh
+ return (IfaceClsInst cls tys dfun flag orph warn)
instance Binary IfaceFamInst where
put_ bh (IfaceFamInst fam tys name orph) = do
@@ -2886,8 +2893,8 @@ instance NFData IfaceFamInst where
rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` ()
instance NFData IfaceClsInst where
- rnf (IfaceClsInst f1 f2 f3 f4 f5) =
- f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` ()
+ rnf (IfaceClsInst f1 f2 f3 f4 f5 f6) =
+ f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` rnf f6
instance NFData IfaceWarnings where
rnf = \case
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 31579f2f5fbc..bd4101cf0c2b 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1228,11 +1228,12 @@ tcRoughTyCon Nothing = RM_WildCard
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
, ifInstCls = cls, ifInstTys = mb_tcs
- , ifInstOrph = orph })
+ , ifInstOrph = orph, ifInstWarn = iface_warn })
= do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
fmap tyThingId (tcIfaceImplicit dfun_name)
; let mb_tcs' = map tcRoughTyCon mb_tcs
- ; return (mkImportedClsInst cls mb_tcs' dfun_name dfun oflag orph) }
+ warn = fmap fromIfaceWarningTxt iface_warn
+ ; return (mkImportedClsInst cls mb_tcs' dfun_name dfun oflag orph warn) }
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 5f9554c4b227..3392ecf8f5f9 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -859,7 +859,7 @@ unitdecls :: { OrdList (LHsUnitDecl PackageName) }
| unitdecl { unitOL $1 }
unitdecl :: { LHsUnitDecl PackageName }
- : 'module' maybe_src modid maybemodwarning maybeexports 'where' body
+ : 'module' maybe_src modid maybe_warning_pragma maybeexports 'where' body
-- XXX not accurate
{ sL1 $1 $ DeclD
(case snd $2 of
@@ -867,7 +867,7 @@ unitdecl :: { LHsUnitDecl PackageName }
IsBoot -> HsBootFile)
(reLoc $3)
(sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $7) $4 Nothing) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7))) }
- | 'signature' modid maybemodwarning maybeexports 'where' body
+ | 'signature' modid maybe_warning_pragma maybeexports 'where' body
{ sL1 $1 $ DeclD
HsigFile
(reLoc $2)
@@ -892,7 +892,7 @@ unitdecl :: { LHsUnitDecl PackageName }
-- know what they are doing. :-)
signature :: { Located (HsModule GhcPs) }
- : 'signature' modid maybemodwarning maybeexports 'where' body
+ : 'signature' modid maybe_warning_pragma maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
acs (\cs-> (L loc (HsModule (XModulePs
(EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6) Nothing) cs)
@@ -902,7 +902,7 @@ signature :: { Located (HsModule GhcPs) }
) }
module :: { Located (HsModule GhcPs) }
- : 'module' modid maybemodwarning maybeexports 'where' body
+ : 'module' modid maybe_warning_pragma maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
acsFinal (\cs eof -> (L loc (HsModule (XModulePs
(EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6) eof) cs)
@@ -924,15 +924,6 @@ missing_module_keyword :: { () }
implicit_top :: { () }
: {- empty -} {% pushModuleContext }
-maybemodwarning :: { Maybe (LocatedP (WarningTxt GhcPs)) }
- : '{-# DEPRECATED' strings '#-}'
- {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
- (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }
- | '{-# WARNING' warning_category strings '#-}'
- {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt $2 (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))
- (AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}
- | {- empty -} { Nothing }
-
body :: { ([TrailingAnn]
,([LImportDecl GhcPs], [LHsDecl GhcPs])
,LayoutInfo GhcPs) }
@@ -959,14 +950,14 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }
-- Module declaration & imports only
header :: { Located (HsModule GhcPs) }
- : 'module' modid maybemodwarning maybeexports 'where' header_body
+ : 'module' modid maybe_warning_pragma maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
acs (\cs -> (L loc (HsModule (XModulePs
(EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] [] Nothing) cs)
NoLayoutInfo $3 Nothing)
(Just $2) $4 $6 []
))) }
- | 'signature' modid maybemodwarning maybeexports 'where' header_body
+ | 'signature' modid maybe_warning_pragma maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
acs (\cs -> (L loc (HsModule (XModulePs
(EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] [] Nothing) cs)
@@ -1026,25 +1017,16 @@ exportlist1 :: { OrdList (LIE GhcPs) }
-- No longer allow things like [] and (,,,) to be exported
-- They are built in syntax, always available
export :: { OrdList (LIE GhcPs) }
- : maybeexportwarning qcname_ext export_subspec {% do { let { span = (maybe comb2 comb3 $1) $2 $> }
+ : maybe_warning_pragma qcname_ext export_subspec {% do { let { span = (maybe comb2 comb3 $1) $2 $> }
; impExp <- mkModuleImpExp $1 (fst $ unLoc $3) $2 (snd $ unLoc $3)
; return $ unitOL $ reLocA $ sL span $ impExp } }
- | maybeexportwarning 'module' modid {% do { let { span = (maybe comb2 comb3 $1) $2 $>
+ | maybe_warning_pragma 'module' modid {% do { let { span = (maybe comb2 comb3 $1) $2 $>
; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 loc) $1) $2 }
; locImpExp <- acs (\cs -> sL span (IEModuleContents ($1, EpAnn anchor [mj AnnModule $2] cs) $3))
; return $ unitOL $ reLocA $ locImpExp } }
- | maybeexportwarning 'pattern' qcon { let span = (maybe comb2 comb3 $1) $2 $>
+ | maybe_warning_pragma 'pattern' qcon { let span = (maybe comb2 comb3 $1) $2 $>
in unitOL $ reLocA $ sL span $ IEVar $1 (sLLa $2 $> (IEPattern (glAA $2) $3)) }
-maybeexportwarning :: { Maybe (LocatedP (WarningTxt GhcPs)) }
- : '{-# DEPRECATED' strings '#-}'
- {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
- (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }
- | '{-# WARNING' warning_category strings '#-}'
- {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt $2 (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))
- (AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}
- | {- empty -} { Nothing }
-
export_subspec :: { Located ([AddEpAnn],ImpExpSubSpec) }
: {- empty -} { sL0 ([],ImpExpAbs) }
| '(' qcnames ')' {% mkImpExpSubSpec (reverse (snd $2))
@@ -1361,17 +1343,17 @@ sks_vars :: { Located [LocatedN RdrName] } -- Returned in reverse order
| oqtycon { sL1 $1 [$1] }
inst_decl :: { LInstDecl GhcPs }
- : 'instance' overlap_pragma inst_type where_inst
- {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)
- ; let anns = (mj AnnInstance $1 : (fst $ unLoc $4))
+ : 'instance' maybe_warning_pragma overlap_pragma inst_type where_inst
+ {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $5)
+ ; let anns = (mj AnnInstance $1 : (fst $ unLoc $5))
; let cid cs = ClsInstDecl
- { cid_ext = (EpAnn (glR $1) anns cs, NoAnnSortKey)
- , cid_poly_ty = $3, cid_binds = binds
+ { cid_ext = ($2, EpAnn (glR $1) anns cs, NoAnnSortKey)
+ , cid_poly_ty = $4, cid_binds = binds
, cid_sigs = mkClassOpSigs sigs
, cid_tyfam_insts = ats
- , cid_overlap_mode = $2
+ , cid_overlap_mode = $3
, cid_datafam_insts = adts }
- ; acsA (\cs -> L (comb3 $1 $3 $4)
+ ; acsA (\cs -> L (comb3 $1 $4 $5)
(ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs }))
} }
@@ -1640,11 +1622,11 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}'
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl GhcPs }
- : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type
+ : 'deriving' deriv_standalone_strategy 'instance' maybe_warning_pragma overlap_pragma inst_type
{% do { let { err = text "in the stand-alone deriving instance"
- <> colon <+> quotes (ppr $5) }
+ <> colon <+> quotes (ppr $6) }
; acsA (\cs -> sLL $1 $>
- (DerivDecl (EpAnn (glR $1) [mj AnnDeriving $1, mj AnnInstance $3] cs) (mkHsWildCardBndrs $5) $2 $4)) }}
+ (DerivDecl ($4, EpAnn (glR $1) [mj AnnDeriving $1, mj AnnInstance $3] cs) (mkHsWildCardBndrs $6) $2 $5)) }}
-----------------------------------------------------------------------------
-- Role annotations
@@ -1986,6 +1968,15 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
-----------------------------------------------------------------------------
-- Warnings and deprecations (c.f. rules)
+maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }
+ : '{-# DEPRECATED' strings '#-}'
+ {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
+ (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }
+ | '{-# WARNING' warning_category strings '#-}'
+ {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt $2 (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))
+ (AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}
+ | {- empty -} { Nothing }
+
warning_category :: { Maybe (Located WarningCategory) }
: 'in' STRING { Just (sL1 $2 (mkWarningCategory (getSTRING $2))) }
| {- empty -} { Nothing }
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index ea8f19053a1c..f249b7d875c4 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2853,7 +2853,7 @@ data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)
| ImpExpQcType EpaLocation (LocatedN RdrName)
| ImpExpQcWildcard
-mkModuleImpExp :: Maybe (LocatedP (WarningTxt GhcPs)) -> [AddEpAnn] -> LocatedA ImpExpQcSpec
+mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> [AddEpAnn] -> LocatedA ImpExpQcSpec
-> ImpExpSubSpec -> P (IE GhcPs)
mkModuleImpExp warning anns (L l specname) subs = do
cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 41515605a867..d972d2ae5eaa 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -1798,12 +1798,12 @@ warnIfDeclDeprecated gre@(GRE { gre_imp = iss })
do { iface <- loadInterfaceForName doc name
; case lookupImpDeclDeprec iface gre of
Just deprText -> addDiagnostic $
- TcRnPragmaWarning {
- pragma_warning_occ = occ,
- pragma_warning_msg = deprText,
- pragma_warning_import_mod = importSpecModule imp_spec,
- pragma_warning_defined_mod = Just definedMod
- }
+ TcRnPragmaWarning
+ PragmaWarningName
+ { pwarn_occname = occ
+ , pwarn_impmod = importSpecModule imp_spec
+ , pwarn_declmod = definedMod }
+ deprText
Nothing -> return () } }
| otherwise
= return ()
@@ -1826,12 +1826,11 @@ 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 {
- pragma_warning_occ = occ,
- pragma_warning_msg = warn_txt,
- pragma_warning_import_mod = importing_mod,
- pragma_warning_defined_mod = Nothing
- } }
+ TcRnPragmaWarning
+ PragmaWarningExport
+ { pwarn_occname = occ
+ , pwarn_impmod = importing_mod }
+ warn_txt }
where
occ = greOccName gre
name = greName gre
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index be4bffb22be7..66f2224241b8 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -13,7 +13,7 @@ Main pass of renamer
-}
module GHC.Rename.Module (
- rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt
+ rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt, rnLWarningTxt
) where
import GHC.Prelude hiding ( head )
@@ -309,6 +309,8 @@ rnWarningTxt (DeprecatedTxt st wst) = do
wst' <- traverse (traverse rnHsDoc) wst
pure (DeprecatedTxt st wst')
+rnLWarningTxt :: LWarningTxt GhcPs -> RnM (LWarningTxt GhcRn)
+rnLWarningTxt (L loc warn) = L loc <$> rnWarningTxt warn
findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)]
findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
@@ -558,7 +560,8 @@ checkCanonicalInstances cls poly_ty mbinds = do
addDiagnostic (TcRnNonCanonicalDefinition reason poly_ty)
rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
-rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
+rnClsInstDecl (ClsInstDecl { cid_ext = (inst_warn_ps, _, _)
+ , cid_poly_ty = inst_ty, cid_binds = mbinds
, cid_sigs = uprags, cid_tyfam_insts = ats
, cid_overlap_mode = oflag
, cid_datafam_insts = adts })
@@ -611,7 +614,8 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
; let all_fvs = meth_fvs `plusFV` more_fvs
`plusFV` inst_fvs
- ; return (ClsInstDecl { cid_ext = noExtField
+ ; inst_warn_rn <- mapM rnLWarningTxt inst_warn_ps
+ ; return (ClsInstDecl { cid_ext = inst_warn_rn
, cid_poly_ty = inst_ty', cid_binds = mbinds'
, cid_sigs = uprags', cid_tyfam_insts = ats'
, cid_overlap_mode = oflag
@@ -1106,7 +1110,7 @@ simplistic solution above, as it fixes the egregious bug in #18470.
-}
rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
-rnSrcDerivDecl (DerivDecl _ ty mds overlap)
+rnSrcDerivDecl (DerivDecl (inst_warn_ps, ann) ty mds overlap)
= do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
; unless standalone_deriv_ok (addErr TcRnUnexpectedStandaloneDerivingDecl)
; checkInferredVars ctxt nowc_ty
@@ -1119,7 +1123,8 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap)
NFC_StandaloneDerivedInstanceHead
(getLHsInstDeclHead $ dropWildCards ty')
; warnNoDerivStrat mds' loc
- ; return (DerivDecl noAnn ty' mds' overlap, fvs) }
+ ; inst_warn_rn <- mapM rnLWarningTxt inst_warn_ps
+ ; return (DerivDecl (inst_warn_rn, ann) ty' mds' overlap, fvs) }
where
ctxt = DerivDeclCtx
loc = getLocA nowc_ty
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index be71785b5b00..0bdb14f30766 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -1258,12 +1258,11 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
reason <- badImportItemErr iface decl_spec ie IsNotSubordinate all_avails
pure (TcRnDodgyImports (DodgyImportsHiding reason))
warning_msg (DeprecatedExport n w) =
- pure (TcRnPragmaWarning {
- pragma_warning_occ = occName n
- , pragma_warning_msg = w
- , pragma_warning_import_mod = moduleName import_mod
- , pragma_warning_defined_mod = Nothing
- })
+ pure $ TcRnPragmaWarning
+ PragmaWarningExport
+ { pwarn_occname = occName n
+ , pwarn_impmod = moduleName import_mod }
+ w
run_lookup :: IELookupM a -> TcRn (Maybe a)
run_lookup m = case m of
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index 262d34875607..2606e145bd0e 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -35,6 +35,7 @@ import GHC.Core.FamInstEnv
import GHC.Tc.Gen.HsType
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr ( pprTyVars )
+import GHC.Unit.Module.Warnings
import GHC.Rename.Bind
import GHC.Rename.Env
@@ -607,7 +608,7 @@ deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
--
-- This returns a Maybe because the user might try to derive Typeable, which is
-- a no-op nowadays.
-deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))
+deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mode))
= setSrcSpanA loc $
addErrCtxt (standaloneCtxt deriv_ty) $
do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
@@ -680,7 +681,8 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))
return Nothing
else Just <$> mkEqnHelp (fmap unLoc overlap_mode)
tvs' cls inst_tys'
- deriv_ctxt' mb_deriv_strat' }
+ deriv_ctxt' mb_deriv_strat'
+ (fmap unLoc warn) }
-- Typecheck the type in a standalone deriving declaration.
--
@@ -855,6 +857,7 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind
; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args
(InferContext Nothing) final_mb_deriv_strat
+ Nothing
; traceTc "deriveTyData 3" (ppr spec)
; return spec }
@@ -1134,13 +1137,14 @@ mkEqnHelp :: Maybe OverlapMode
-- InferContext => context inferred (deriving on data decl, or
-- standalone deriving decl with a wildcard)
-> Maybe (DerivStrategy GhcTc)
+ -> Maybe (WarningTxt GhcRn)
-> TcRn EarlyDerivSpec
-- Make the EarlyDerivSpec for an instance
-- forall tvs. theta => cls (tys ++ [ty])
-- where the 'theta' is optional (that's the Maybe part)
-- Assumes that this declaration is well-kinded
-mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do
+mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat warn = do
is_boot <- tcIsHsBootOrSig
when is_boot $ bale_out DerivErrBootFileFound
@@ -1155,7 +1159,8 @@ mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do
, denv_inst_tys = cls_args'
, denv_ctxt = deriv_ctxt
, denv_skol_info = skol_info
- , denv_strat = deriv_strat' }
+ , denv_strat = deriv_strat'
+ , denv_warn = warn }
runReaderT mk_eqn deriv_env
where
skolemise_when_inferring_context ::
@@ -1341,7 +1346,8 @@ mk_eqn_from_mechanism mechanism
, denv_cls = cls
, denv_inst_tys = inst_tys
, denv_ctxt = deriv_ctxt
- , denv_skol_info = skol_info } <- ask
+ , denv_skol_info = skol_info
+ , denv_warn = warn } <- ask
user_ctxt <- askDerivUserTypeCtxt
doDerivInstErrorChecks1 mechanism
loc <- lift getSrcSpanM
@@ -1359,7 +1365,8 @@ mk_eqn_from_mechanism mechanism
, ds_user_ctxt = user_ctxt
, ds_overlap = overlap_mode
, ds_standalone_wildcard = wildcard
- , ds_mechanism = mechanism' } }
+ , ds_mechanism = mechanism'
+ , ds_warn = warn } }
SupplyContext theta ->
return $ GivenTheta $ DS
@@ -1371,7 +1378,8 @@ mk_eqn_from_mechanism mechanism
, ds_user_ctxt = user_ctxt
, ds_overlap = overlap_mode
, ds_standalone_wildcard = Nothing
- , ds_mechanism = mechanism }
+ , ds_mechanism = mechanism
+ , ds_warn = warn }
mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class
-> DerivM EarlyDerivSpec
diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs
index a5fe83097dbb..e2f179b4ff09 100644
--- a/compiler/GHC/Tc/Deriv/Utils.hs
+++ b/compiler/GHC/Tc/Deriv/Utils.hs
@@ -26,6 +26,7 @@ module GHC.Tc.Deriv.Utils (
import GHC.Prelude
+import GHC.Hs.Extension
import GHC.Data.Bag
import GHC.Types.Basic
@@ -51,6 +52,7 @@ import GHC.Core.Type
import GHC.Hs
import GHC.Driver.Session
import GHC.Unit.Module (getModule)
+import GHC.Unit.Module.Warnings
import GHC.Unit.Module.ModIface (mi_fix)
import GHC.Types.Fixity.Env (lookupFixity)
@@ -144,6 +146,8 @@ data DerivEnv = DerivEnv
, denv_strat :: Maybe (DerivStrategy GhcTc)
-- ^ 'Just' if user requests a particular deriving strategy.
-- Otherwise, 'Nothing'.
+ , denv_warn :: Maybe (WarningTxt GhcRn)
+ -- ^ A warning to emit whenever the derived instance is used
}
instance Outputable DerivEnv where
@@ -175,7 +179,8 @@ data DerivSpec theta = DS { ds_loc :: SrcSpan
, ds_standalone_wildcard :: Maybe SrcSpan
-- See Note [Inferring the instance context]
-- in GHC.Tc.Deriv.Infer
- , ds_mechanism :: DerivSpecMechanism }
+ , ds_mechanism :: DerivSpecMechanism
+ , ds_warn :: Maybe (WarningTxt GhcRn)}
-- This spec implies a dfun declaration of the form
-- df :: forall tvs. theta => C tys
-- The Name is the name for the DFun we'll build
@@ -1182,8 +1187,9 @@ non_coercible_class cls
newDerivClsInst :: DerivSpec ThetaType -> TcM ClsInst
newDerivClsInst (DS { ds_name = dfun_name, ds_overlap = overlap_mode
, ds_tvs = tvs, ds_theta = theta
- , ds_cls = clas, ds_tys = tys })
- = newClsInst overlap_mode dfun_name tvs theta clas tys
+ , ds_cls = clas, ds_tys = tys
+ , ds_warn = warn })
+ = newClsInst overlap_mode dfun_name tvs theta clas tys warn
extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
-- Add new locally-defined instances; don't bother to check
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 72080273b2be..5bbf2ecbee93 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1067,20 +1067,29 @@ instance Diagnostic TcRnMessage where
-> mkSimpleDecorated $
text "You cannot SPECIALISE" <+> quotes (ppr name)
<+> text "because its definition is not visible in this module"
- TcRnPragmaWarning {pragma_warning_occ, pragma_warning_msg, pragma_warning_import_mod, pragma_warning_defined_mod}
+ TcRnPragmaWarning
+ { pragma_warning_info = PragmaWarningInstance{pwarn_dfunid, pwarn_ctorig}
+ , pragma_warning_msg }
+ -> mkSimpleDecorated $
+ sep [ hang (text "In the use of")
+ 2 (pprDFunId pwarn_dfunid)
+ , ppr pwarn_ctorig
+ , pprWarningTxtForMsg pragma_warning_msg
+ ]
+ TcRnPragmaWarning {pragma_warning_info, pragma_warning_msg}
-> mkSimpleDecorated $
sep [ sep [ text "In the use of"
- <+> pprNonVarNameSpace (occNameSpace pragma_warning_occ)
- <+> quotes (ppr pragma_warning_occ)
- , parens impMsg <> colon ]
+ <+> pprNonVarNameSpace (occNameSpace occ_name)
+ <+> quotes (ppr occ_name)
+ , parens imp_msg <> colon ]
, pprWarningTxtForMsg pragma_warning_msg ]
where
- impMsg = text "imported from" <+> ppr pragma_warning_import_mod <> extra
- extra = case pragma_warning_defined_mod of
- Just def_mod
- | def_mod /= pragma_warning_import_mod
- -> text ", but defined in" <+> ppr def_mod
- _ -> empty
+ occ_name = pwarn_occname pragma_warning_info
+ imp_mod = pwarn_impmod pragma_warning_info
+ imp_msg = text "imported from" <+> ppr imp_mod <> extra
+ extra | PragmaWarningName {pwarn_declmod = decl_mod} <- pragma_warning_info
+ , imp_mod /= decl_mod = text ", but defined in" <+> ppr decl_mod
+ | otherwise = empty
TcRnDifferentExportWarnings name locs
-> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "exported with different error messages",
text "at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)]
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 044070578f0b..e9f838e65f23 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -84,6 +84,7 @@ module GHC.Tc.Errors.Types (
, ExpectedBackends
, ArgOrResult(..)
, MatchArgsContext(..), MatchArgBadMatches(..)
+ , PragmaWarningInfo(..)
, EmptyStatementGroupErrReason(..)
, UnexpectedStatement(..)
, DeclSort(..)
@@ -2489,12 +2490,17 @@ data TcRnMessage where
rn050
rn066 (here is a warning, not deprecation)
T3303
+ ExportWarnings1
+ ExportWarnings2
+ ExportWarnings3
+ ExportWarnings4
+ ExportWarnings5
+ ExportWarnings6
+ InstanceWarnings
-}
TcRnPragmaWarning :: {
- pragma_warning_occ :: OccName,
- pragma_warning_msg :: WarningTxt GhcRn,
- pragma_warning_import_mod :: ModuleName,
- pragma_warning_defined_mod :: Maybe ModuleName
+ pragma_warning_info :: PragmaWarningInfo,
+ pragma_warning_msg :: WarningTxt GhcRn
} -> TcRnMessage
{-| TcRnDifferentExportWarnings is an error that occurs when the
@@ -5695,6 +5701,16 @@ data MatchArgBadMatches where
, matchArgBadMatches :: NE.NonEmpty (LocatedA (Match GhcRn body)) }
-> MatchArgBadMatches
+data PragmaWarningInfo
+ = PragmaWarningName { pwarn_occname :: OccName
+ , pwarn_impmod :: ModuleName
+ , pwarn_declmod :: ModuleName }
+ | PragmaWarningExport { pwarn_occname :: OccName
+ , pwarn_impmod :: ModuleName }
+ | PragmaWarningInstance { pwarn_dfunid :: DFunId
+ , pwarn_ctorig :: CtOrigin }
+
+
-- | The context for an "empty statement group" error.
data EmptyStatementGroupErrReason
= EmptyStmtsGroupInParallelComp
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index 6b03d136b014..c189dcc140dd 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -523,9 +523,6 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
-------------
- rn_warning_txt_loc :: LocatedP (WarningTxt GhcPs) -> RnM (LocatedP (WarningTxt GhcRn))
- rn_warning_txt_loc (L loc warn_txt) = L loc <$> rnWarningTxt warn_txt
-
-- Runs for every Name
-- - If there is no new warning, flags that the old warning should not be
-- included (since a warning should only be emitted if all
@@ -534,12 +531,12 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
process_warning :: ExportWarnSpanNames -- Old aggregate data about warnins
-> DontWarnExportNames -- Old names not to warn about
-> [Name] -- Names to warn about
- -> Maybe (LocatedP (WarningTxt GhcPs)) -- Warning
+ -> Maybe (LWarningTxt GhcPs) -- Warning
-> SrcSpan -- Span of the export list item
-> RnM (ExportWarnSpanNames, -- Aggregate data about the warnings
DontWarnExportNames, -- Names not to warn about in the end
-- (when there was a non-warned export)
- Maybe (LocatedP (WarningTxt GhcRn))) -- Renamed warning
+ Maybe (LWarningTxt GhcRn)) -- Renamed warning
process_warning export_warn_spans
dont_warn_export
names Nothing loc
@@ -560,7 +557,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
dont_warn_export
names (Just warn_txt_ps) loc
= do
- warn_txt_rn <- rn_warning_txt_loc warn_txt_ps
+ warn_txt_rn <- rnLWarningTxt warn_txt_ps
let new_export_warn_spans = map (, unLoc warn_txt_rn, loc) names
return ( new_export_warn_spans ++ export_warn_spans
, dont_warn_export
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index bb2182817a9d..838052ab2c55 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -53,6 +53,10 @@ import GHC.Utils.Panic
import GHC.Utils.Misc( splitAtList, fstOf3 )
import GHC.Data.FastString
+import GHC.Unit.Module.Warnings
+
+import GHC.Hs.Extension
+
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import GHC.Types.Id.Info
import GHC.Tc.Errors.Types
@@ -177,13 +181,14 @@ matchInstEnv dflags short_cut_solver clas tys
| otherwise
-> do { let dfun_id = instanceDFunId ispec
+ warn = instanceWarning ispec
; traceTc "matchClass success" $
vcat [text "dict" <+> ppr pred,
ppr coherence,
text "witness" <+> ppr dfun_id
<+> ppr (idType dfun_id) ]
-- Record that this dfun is needed
- ; match_one (null unsafeOverlaps) coherence dfun_id inst_tys }
+ ; match_one (null unsafeOverlaps) coherence dfun_id inst_tys warn }
-- More than one matches (or Safe Haskell fail!). Defer any
-- reactions of a multitude until we learn more about the reagent
@@ -194,9 +199,10 @@ matchInstEnv dflags short_cut_solver clas tys
where
pred = mkClassPred clas tys
-match_one :: SafeOverlapping -> Coherence -> DFunId -> [DFunInstType] -> TcM ClsInstResult
+match_one :: SafeOverlapping -> Coherence -> DFunId -> [DFunInstType]
+ -> Maybe (WarningTxt GhcRn) -> TcM ClsInstResult
-- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv
-match_one so coherence dfun_id mb_inst_tys
+match_one so coherence dfun_id mb_inst_tys warn
= do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys)
; (tys, theta) <- instDFunType dfun_id mb_inst_tys
; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta)
@@ -204,7 +210,8 @@ match_one so coherence dfun_id mb_inst_tys
, cir_mk_ev = evDFunApp dfun_id tys
, cir_coherence = coherence
, cir_what = TopLevInstance { iw_dfun_id = dfun_id
- , iw_safe_over = so } } }
+ , iw_safe_over = so
+ , iw_warn = warn } } }
{- Note [Shortcut solving: overlap]
diff --git a/compiler/GHC/Tc/Solver/Dict.hs b/compiler/GHC/Tc/Solver/Dict.hs
index 8e5b0cac9615..80e6af0a71b0 100644
--- a/compiler/GHC/Tc/Solver/Dict.hs
+++ b/compiler/GHC/Tc/Solver/Dict.hs
@@ -34,6 +34,7 @@ import GHC.Core.Predicate
import GHC.Core.Multiplicity ( scaledThing )
import GHC.Core.Unify ( ruleMatchTyKiX )
+import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Var
import GHC.Types.Id( mkTemplateLocals )
@@ -46,6 +47,8 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
+import GHC.Unit.Module
+
import GHC.Data.Bag
import GHC.Driver.DynFlags
@@ -57,7 +60,7 @@ import Data.Void( Void )
import Control.Monad.Trans.Maybe( MaybeT, runMaybeT )
import Control.Monad.Trans.Class( lift )
-import Control.Monad( mzero )
+import Control.Monad
{- *********************************************************************
@@ -781,6 +784,8 @@ shortCutSolver dflags ev_w ev_i
| let pred = ctEvPred ev
, ClassPred cls tys <- classifyPredType pred
= do { inst_res <- lift $ matchGlobalInst dflags True cls tys loc_w
+ ; lift $ warn_custom_warn_instance inst_res loc_w
+ -- See Note [Implementation of deprecated instances]
; case inst_res of
OneInst { cir_new_theta = preds
, cir_mk_ev = mk_ev
@@ -940,11 +945,63 @@ matchClassInst dflags inerts clas tys loc
NoInstance -- No local instances, so try global ones
-> do { global_res <- matchGlobalInst dflags False clas tys loc
+ ; warn_custom_warn_instance global_res loc
+ -- See Note [Implementation of deprecated instances]
; traceTcS "} matchClassInst global result" $ ppr global_res
; return global_res } }
where
pred = mkClassPred clas tys
+{- Note [Implementation of deprecated instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This note describes the implementation of the deprecated instances GHC proposal
+ https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0575-deprecated-instances.rst
+
+In the parser, we parse deprecations/warnings attached to instances:
+
+ instance {-# DEPRECATED "msg" #-} Show X
+ deriving instance {-# WARNING "msg2" #-} Eq Y
+
+(Note that non-standalone deriving instance declarations do not support this mechanism.)
+(Note that the DEPRECATED and WARNING pragmas can be used here interchangeably.)
+
+We store the resulting warning message in the extension field of `ClsInstDecl`
+(respectively, `DerivDecl`; See Note [Trees That Grow]).
+
+In `GHC.Tc.TyCl.Instance.tcClsInstDecl` (respectively, `GHC.Tc.Deriv.Utils.newDerivClsInst`),
+we pass on that information to `ClsInst` (and eventually store it in `IfaceClsInst` too).
+
+Next, if we solve a constraint using such an instance, in
+`GHC.Tc.Instance.Class.matchInstEnv`, we pass it further into the
+`Ghc.Tc.Types.Origin.InstanceWhat`.
+
+Finally, if the instance solving function `GHC.Tc.Solver.Monad.matchGlobalInst` returns
+a `Ghc.Tc.Instance.Class.ClsInstResult` with `Ghc.Tc.Types.Origin.InstanceWhat` containing
+a warning, when called from either `matchClassInst` or `shortCutSolver`, we call
+`warn_custom_warn_instance` that ultimately emits the warning if needed.
+
+Note that we only emit a warning when the instance is used in a different module
+than it is defined, which keeps the behaviour in line with the deprecation of
+top-level identifiers.
+-}
+
+-- | Emits the custom warning for a deprecated instance
+--
+-- See Note [Implementation of deprecated instances]
+warn_custom_warn_instance :: ClsInstResult -> CtLoc -> TcS ()
+warn_custom_warn_instance (OneInst{ cir_what = what }) ct_loc
+ | TopLevInstance{ iw_dfun_id = dfun, iw_warn = Just warn } <- what = do
+ let mod = nameModule $ getName dfun
+ this_mod <- getModule
+ when (this_mod /= mod)
+ -- We don't emit warnings for usages inside of the same module
+ -- to prevent it being triggered for instance child declarations
+ $ ctLocWarnTcS ct_loc
+ $ TcRnPragmaWarning
+ { pragma_warning_info = PragmaWarningInstance dfun (ctl_origin ct_loc)
+ , pragma_warning_msg = warn }
+warn_custom_warn_instance _ _ = return ()
+
{- Note [Instance and Given overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Example, from the OutsideIn(X) paper:
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index a8f2f7dc18ff..e4ef45693eeb 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -487,7 +487,8 @@ tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
tcClsInstDecl :: LClsInstDecl GhcRn
-> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
-- The returned DerivInfos are for any associated data families
-tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
+tcClsInstDecl (L loc (ClsInstDecl { cid_ext = lwarn
+ , cid_poly_ty = hs_ty, cid_binds = binds
, cid_sigs = uprags, cid_tyfam_insts = ats
, cid_overlap_mode = overlap_mode
, cid_datafam_insts = adts }))
@@ -542,8 +543,9 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
; dfun_name <- newDFunName clas inst_tys (getLocA hs_ty)
-- Dfun location is that of instance *header*
+ ; let warn = fmap unLoc lwarn
; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name
- tyvars theta clas inst_tys
+ tyvars theta clas inst_tys warn
; let inst_binds = InstBindings
{ ib_binds = binds
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 686b384d0612..12191d23cb45 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -64,6 +64,7 @@ import GHC.Core.PatSyn
import GHC.Core.Multiplicity ( scaledThing )
import GHC.Unit.Module
+import GHC.Unit.Module.Warnings
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -1518,7 +1519,10 @@ data InstanceWhat -- How did we solve this constraint?
| TopLevInstance -- Solved by a top-level instance decl
{ iw_dfun_id :: DFunId
- , iw_safe_over :: SafeOverlapping }
+ , iw_safe_over :: SafeOverlapping
+ , iw_warn :: Maybe (WarningTxt GhcRn) }
+ -- See Note [Implementation of deprecated instances]
+ -- in GHC.Tc.Solver.Dict
instance Outputable InstanceWhat where
ppr BuiltinInstance = text "a built-in instance"
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index c978eb6533a7..9054580669c5 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -94,6 +94,7 @@ import GHC.Utils.Unique (sameUnique)
import GHC.Unit.State
import GHC.Unit.External
+import GHC.Unit.Module.Warnings
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
@@ -855,8 +856,8 @@ tcGetInsts :: TcM [ClsInst]
tcGetInsts = fmap tcg_insts getGblEnv
newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
- -> Class -> [Type] -> TcM ClsInst
-newClsInst overlap_mode dfun_name tvs theta clas tys
+ -> Class -> [Type] -> Maybe (WarningTxt GhcRn) -> TcM ClsInst
+newClsInst overlap_mode dfun_name tvs theta clas tys warn
= do { (subst, tvs') <- freshenTyVarBndrs tvs
-- Be sure to freshen those type variables,
-- so they are sure not to appear in any lookup
@@ -870,7 +871,7 @@ newClsInst overlap_mode dfun_name tvs theta clas tys
-- helpful to use the same names
; oflag <- getOverlapFlag overlap_mode
- ; let cls_inst = mkLocalClsInst dfun oflag tvs' clas tys'
+ ; let cls_inst = mkLocalClsInst dfun oflag tvs' clas tys' warn
; when (isOrphan (is_orphan cls_inst)) $
addDiagnostic (TcRnOrphanInstance $ Left cls_inst)
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index e884c5b2cec0..e047a0478d25 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -319,7 +319,7 @@ cvtDec (InstanceD o ctxt ty decs)
; let inst_ty' = L loc $ mkHsImplicitSigType $
mkHsQualTy ctxt loc ctxt' $ L loc ty'
; returnJustLA $ InstD noExtField $ ClsInstD noExtField $
- ClsInstDecl { cid_ext = (noAnn, NoAnnSortKey), cid_poly_ty = inst_ty'
+ ClsInstDecl { cid_ext = (Nothing, noAnn, NoAnnSortKey), cid_poly_ty = inst_ty'
, cid_binds = binds'
, cid_sigs = Hs.mkClassOpSigs sigs'
, cid_tyfam_insts = ats', cid_datafam_insts = adts'
@@ -421,7 +421,7 @@ cvtDec (TH.StandaloneDerivD ds cxt ty)
; let inst_ty' = L loc $ mkHsImplicitSigType $
mkHsQualTy cxt loc cxt' $ L loc ty'
; returnJustLA $ DerivD noExtField $
- DerivDecl { deriv_ext = noAnn
+ DerivDecl { deriv_ext = (Nothing, noAnn)
, deriv_strategy = ds'
, deriv_type = mkHsWildCardBndrs inst_ty'
, deriv_overlap_mode = Nothing } }
diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs
index 684493609e2c..516dd0d1fcae 100644
--- a/compiler/GHC/Unit/Module/Warnings.hs
+++ b/compiler/GHC/Unit/Module/Warnings.hs
@@ -7,6 +7,7 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
-- | Warnings for a module
module GHC.Unit.Module.Warnings
@@ -25,6 +26,7 @@ module GHC.Unit.Module.Warnings
, Warnings (..)
, WarningTxt (..)
+ , LWarningTxt
, DeclWarnOccNames
, ExportWarnNames
, warningTxtCategory
@@ -51,6 +53,8 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Hs.Doc
+import GHC.Hs.Extension
+import GHC.Parser.Annotation
import GHC.Utils.Outputable
import GHC.Utils.Binary
@@ -178,6 +182,7 @@ deleteWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCate
deleteWarningCategorySet c (FiniteWarningCategorySet s) = FiniteWarningCategorySet (delOneFromUniqSet s c)
deleteWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCategorySet (addOneToUniqSet s c)
+type LWarningTxt pass = XRec pass (WarningTxt pass)
-- | Warning Text
--
@@ -221,6 +226,7 @@ warningTxtSame w1 w2
deriving instance Eq (IdP pass) => Eq (WarningTxt pass)
deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass)
+type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP
instance Outputable (WarningTxt pass) where
ppr (WarningTxt mcat lsrc ws)
= case unLoc lsrc of
diff --git a/docs/users_guide/exts/pragmas.rst b/docs/users_guide/exts/pragmas.rst
index 6236df7beea0..b82844e52cf7 100644
--- a/docs/users_guide/exts/pragmas.rst
+++ b/docs/users_guide/exts/pragmas.rst
@@ -141,53 +141,75 @@ There are three ways of using these pragmas.
both are in scope. If both are in scope, there is currently no way to
specify one without the other (c.f. fixities :ref:`infix-tycons`).
-- You can also attach a warning to an export field, be it a regular export: ::
+- You can add a warning to an instance (including derived instances): ::
+
+ instance {-# DEPRECATED "Don't use" #-} Show T1 where { .. }
+ instance {-# WARNING "Don't use either" #-} Show G1 where { .. }
+
+ deriving instance {-# DEPRECATED "to be removed" #-} Eq T2
+ deriving instance {-# WARNING "to be removed as well" #-} Eq G2
+
+ Doing so will cause warnings to be emitted whenever such instances are used
+ to solve a constraint. For example: ::
+
+ foo = show (MkT1 :: T1) -- warning: uses "instance Show T1"
+
+ bar :: forall a. Eq a => a -> Bool
+ bar x = x == x
+ baz :: T2 -> Bool
+ baz = bar -- warning: uses "instance Eq T2"
+ quux :: Eq T2 => T2 -> Bool
+ quux = bar -- no warning: does not use "instance Eq T2"
+
+ As with other deprecation mechanisms, note that warnings will not be emitted
+ for the usages of those instances in the module in which they are defined.
+
+- Finally, you can attach a warning to an export field, be it a regular export: ::
module Wibble (
{-# DEPRECATED "Do not use this type" #-} T,
{-# WARNING "This is a hacky function" #-} f
) where
...
-
- Or a re-export of import from another module: ::
-
+
+ Or a re-export of import from another module: ::
+
module Wibble (
{-# DEPRECATED "Import this function from A instead" #-} g
) where
import A
-
+
Or a re-export of an entire module: ::
-
+
module Wibble (
- {-# DEPRECATED "This declaration has been moved to B instead"
+ {-# DEPRECATED "This declaration has been moved to B instead" #-}
module B
) where
import B
-
+
When you compile any module that imports and uses any of the
specified entities, GHC will print the specified message.
An entity will only be warned about if all of its exports are deprecated: ::
-
+
module Wibble (
{-# WARNING "This would not be warned about" #-} g,
module A
)
import A (g)
-
- If the :ghc-flag: `-Wincomplete-export-warnings` is on,
+
+ If the :ghc-flag: `-Wincomplete-export-warnings` is on,
such occurences are warned about.
- Moreover, all warning declarations of a specific name have to
+ Moreover, all warning declarations of a specific name have to
be warned with the same pragma and message: ::
-
+
module Wibble (
{-# WARNING "This would throw an error" #-} T(T1),
{-# WARNING "Because the warning messages differ for T" #-} T,
)
...
-
Also note that the argument to ``DEPRECATED`` and ``WARNING`` can also be a list
of strings, in which case the strings will be presented on separate lines in the
resulting warning message, ::
@@ -195,11 +217,11 @@ resulting warning message, ::
{-# DEPRECATED foo, bar ["Don't use these", "Use gar instead"] #-}
Warnings and deprecations are not reported for (a) uses within the
-defining module, (b) defining a method in a class instance,
-(c) unqualified uses of an entity imported through different modules
-when not all of them are warned about, and (d) uses in an
-export list (except for export warnings). The latter reduces
-spurious complaints within a library in which one module gathers together
+defining module, (b) defining a method in a class instance,
+(c) unqualified uses of an entity imported through different modules
+when not all of them are warned about, and (d) uses in an
+export list (except for export warnings). The latter reduces
+spurious complaints within a library in which one module gathers together
and re-exports the exports of several others.
A ``WARNING`` pragma (but not a ``DEPRECATED`` pragma) may optionally specify a
diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
index a81f39b6e1a9..869c7609ff00 100644
--- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
+++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
@@ -12,7 +12,7 @@
(AnnsModule
[(AddEpAnn AnnModule (EpaSpan { T17544.hs:3:1-6 }))
,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:3:15-19 }))]
- []
+ []
(Just
((,)
{ T17544.hs:57:1 }
@@ -746,7 +746,8 @@
(ClsInstD
(NoExtField)
(ClsInstDecl
- ((,)
+ ((,,)
+ (Nothing)
(EpAnn
(Anchor
{ T17544.hs:23:1-8 }
@@ -1023,7 +1024,8 @@
(ClsInstD
(NoExtField)
(ClsInstDecl
- ((,)
+ ((,,)
+ (Nothing)
(EpAnn
(Anchor
{ T17544.hs:29:1-8 }
@@ -1300,7 +1302,8 @@
(ClsInstD
(NoExtField)
(ClsInstDecl
- ((,)
+ ((,,)
+ (Nothing)
(EpAnn
(Anchor
{ T17544.hs:35:1-8 }
@@ -1577,7 +1580,8 @@
(ClsInstD
(NoExtField)
(ClsInstDecl
- ((,)
+ ((,,)
+ (Nothing)
(EpAnn
(Anchor
{ T17544.hs:41:1-8 }
@@ -1854,7 +1858,8 @@
(ClsInstD
(NoExtField)
(ClsInstDecl
- ((,)
+ ((,,)
+ (Nothing)
(EpAnn
(Anchor
{ T17544.hs:47:1-8 }
@@ -2131,7 +2136,8 @@
(ClsInstD
(NoExtField)
(ClsInstDecl
- ((,)
+ ((,,)
+ (Nothing)
(EpAnn
(Anchor
{ T17544.hs:53:1-8 }
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index 3d03be0f8fc8..bce7098e03be 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -1310,7 +1310,7 @@
(ClsInstD
(NoExtField)
(ClsInstDecl
- (NoExtField)
+ (Nothing)
(L
(SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:31:10-14 })
(HsSig
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 547cfc6d33db..7d57d53595c9 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -734,6 +734,11 @@ PprExportWarn:
$(CHECK_PPR) $(LIBDIR) PprExportWarn.hs
$(CHECK_EXACT) $(LIBDIR) PprExportWarn.hs
+.PHONY: PprInstanceWarn
+PprInstanceWarn:
+ $(CHECK_PPR) $(LIBDIR) PprInstanceWarn.hs
+ $(CHECK_EXACT) $(LIBDIR) PprInstanceWarn.hs
+
.PHONY: Test20243
Test20243:
$(CHECK_PPR) $(LIBDIR) Test20243.hs
diff --git a/testsuite/tests/printer/PprInstanceWarn.hs b/testsuite/tests/printer/PprInstanceWarn.hs
new file mode 100644
index 000000000000..9f8f2f135ef9
--- /dev/null
+++ b/testsuite/tests/printer/PprInstanceWarn.hs
@@ -0,0 +1,11 @@
+module PprInstanceWarning where
+
+data D a = D a
+
+instance {-# DEPRECATED "do not use" #-} {-# OVERLAPPING #-} Show (D a) where
+ show (D _) = "D"
+
+instance {-# WARNING "do not use either" #-} {-# OVERLAPPABLE #-} Show (D a) where
+ show (D _) = "Not D"
+
+deriving instance {-# WARNING "definitely bad" #-} Show a => Show (D a)
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 3c57cca8baec..71bc05dacdb5 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -172,6 +172,7 @@ test('PprBracesSemiDataDecl', [ignore_stderr, req_ppr_deps], makefile_test, ['Pp
test('PprUnicodeSyntax', [ignore_stderr, req_ppr_deps], makefile_test, ['PprUnicodeSyntax'])
test('PprCommentPlacement2', [ignore_stderr, req_ppr_deps], makefile_test, ['PprCommentPlacement2'])
test('PprExportWarn', [ignore_stderr, req_ppr_deps], makefile_test, ['PprExportWarn'])
+test('PprInstanceWarn', [ignore_stderr, req_ppr_deps], makefile_test, ['PprInstanceWarn'])
test('Test20243', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20243'])
test('Test20247', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20247'])
diff --git a/testsuite/tests/typecheck/should_compile/InstanceWarnings.hs b/testsuite/tests/typecheck/should_compile/InstanceWarnings.hs
new file mode 100644
index 000000000000..d20bc7a84307
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InstanceWarnings.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE GADTs #-}
+module InstanceWarnings where
+import InstanceWarnings_aux
+
+data Sel a where
+ S1 :: Sel Int
+ S2 :: Sel Bool
+ S3 :: Sel Char
+
+f :: T a -> Sel a -> String
+f t S1 = show t
+f t S2 = show t
+f t S3 = if t == T2 then show t else ""
\ No newline at end of file
diff --git a/testsuite/tests/typecheck/should_compile/InstanceWarnings.stderr b/testsuite/tests/typecheck/should_compile/InstanceWarnings.stderr
new file mode 100644
index 000000000000..d36345cb5f85
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InstanceWarnings.stderr
@@ -0,0 +1,29 @@
+[1 of 2] Compiling InstanceWarnings_aux ( InstanceWarnings_aux.hs, InstanceWarnings_aux.o )
+[2 of 2] Compiling InstanceWarnings ( InstanceWarnings.hs, InstanceWarnings.o )
+
+InstanceWarnings.hs:11:10: warning: [GHC-63394] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of
+ instance Show (T Int) -- Defined at InstanceWarnings_aux.hs:5:38
+ arising from a use of ‘show’
+ "Don't use"
+
+InstanceWarnings.hs:12:10: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of
+ instance Show (T Bool) -- Defined at InstanceWarnings_aux.hs:8:48
+ arising from a use of ‘show’
+ Deprecated: "Don't use either"
+
+InstanceWarnings.hs:13:15: warning: [GHC-63394] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of
+ instance Eq a => Eq (T a)
+ -- Defined at InstanceWarnings_aux.hs:14:1
+ arising from a use of ‘==’
+ "Deprecated deriving"
+
+InstanceWarnings.hs:13:26: warning: [GHC-63394] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of
+ instance Show (T Char) -- Defined at InstanceWarnings_aux.hs:11:56
+ arising from a use of ‘show’
+ "Don't
+ use
+ multiline"
diff --git a/testsuite/tests/typecheck/should_compile/InstanceWarnings_aux.hs b/testsuite/tests/typecheck/should_compile/InstanceWarnings_aux.hs
new file mode 100644
index 000000000000..fb390062c467
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InstanceWarnings_aux.hs
@@ -0,0 +1,14 @@
+module InstanceWarnings_aux where
+
+data T a = T1 a | T2
+
+instance {-# WARNING "Don't use" #-} Show (T Int) where
+ show _ = "T Int"
+
+instance {-# DEPRECATED "Don't use either" #-} Show (T Bool) where
+ show _ = "T Bool"
+
+instance {-# WARNING ["Don't", "use", "multiline"] #-} Show (T Char) where
+ show _ = "T Char"
+
+deriving instance {-# WARNING "Deprecated deriving" #-} Eq a => Eq (T a)
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index dbc9b6da60e8..0b98018f813e 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -890,3 +890,4 @@ test('T18986a', normal, compile, [''])
test('T18986b', normal, compile, [''])
test('T23413', normal, compile, [''])
test('TcIncompleteRecSel', normal, compile, ['-Wincomplete-record-selectors'])
+test('InstanceWarnings', normal, multimod_compile, ['InstanceWarnings', ''])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 1eaa26853e41..368d19305fd6 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -1642,15 +1642,17 @@ rendering the DataDefn are contained in the FamEqn, and are called
-- ---------------------------------------------------------------------
instance ExactPrint (DerivDecl GhcPs) where
- getAnnotationEntry (DerivDecl {deriv_ext = an} ) = fromAnn an
- setAnnotationAnchor dd anc cs = dd { deriv_ext = setAnchorEpa (deriv_ext dd) anc cs }
- exact (DerivDecl an typ ms mov) = do
+ getAnnotationEntry (DerivDecl {deriv_ext = (_, an)} ) = fromAnn an
+ setAnnotationAnchor (dd@DerivDecl {deriv_ext = (w, an)}) anc cs
+ = dd { deriv_ext = (w, setAnchorEpa an anc cs) }
+ exact (DerivDecl (mw, an) typ ms mov) = do
an0 <- markEpAnnL an lidl AnnDeriving
ms' <- mapM markAnnotated ms
an1 <- markEpAnnL an0 lidl AnnInstance
+ mw' <- mapM markAnnotated mw
mov' <- mapM markAnnotated mov
typ' <- markAnnotated typ
- return (DerivDecl an1 typ' ms' mov')
+ return (DerivDecl (mw', an1) typ' ms' mov')
-- ---------------------------------------------------------------------
@@ -1993,17 +1995,17 @@ instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty)
-- ---------------------------------------------------------------------
instance ExactPrint (ClsInstDecl GhcPs) where
- getAnnotationEntry cid = fromAnn (fst $ cid_ext cid)
- setAnnotationAnchor cid anc cs
- = cid { cid_ext = (setAnchorEpa (fst $ cid_ext cid) anc cs, (snd $ cid_ext cid)) }
+ getAnnotationEntry (ClsInstDecl { cid_ext = (_, an, _) }) = fromAnn an
+ setAnnotationAnchor (cid@ClsInstDecl { cid_ext = (mbWarn, an, sortKey) }) anc cs
+ = cid { cid_ext = (mbWarn, setAnchorEpa an anc cs, sortKey) }
- exact (ClsInstDecl { cid_ext = (an, sortKey)
+ exact (ClsInstDecl { cid_ext = (mbWarn, an, sortKey)
, cid_poly_ty = inst_ty, cid_binds = binds
, cid_sigs = sigs, cid_tyfam_insts = ats
, cid_overlap_mode = mbOverlap
, cid_datafam_insts = adts })
= do
- (an0, mbOverlap', inst_ty') <- top_matter
+ (mbWarn', an0, mbOverlap', inst_ty') <- top_matter
an1 <- markEpAnnL an0 lidl AnnOpenC
an2 <- markEpAnnAllL an1 lid AnnSemi
ds <- withSortKey sortKey
@@ -2018,7 +2020,7 @@ instance ExactPrint (ClsInstDecl GhcPs) where
adts' = undynamic ds
binds' = listToBag $ undynamic ds
sigs' = undynamic ds
- return (ClsInstDecl { cid_ext = (an3, sortKey)
+ return (ClsInstDecl { cid_ext = (mbWarn', an3, sortKey)
, cid_poly_ty = inst_ty', cid_binds = binds'
, cid_sigs = sigs', cid_tyfam_insts = ats'
, cid_overlap_mode = mbOverlap'
@@ -2027,10 +2029,11 @@ instance ExactPrint (ClsInstDecl GhcPs) where
where
top_matter = do
an0 <- markEpAnnL an lidl AnnInstance
+ mw <- mapM markAnnotated mbWarn
mo <- mapM markAnnotated mbOverlap
it <- markAnnotated inst_ty
an1 <- markEpAnnL an0 lidl AnnWhere -- Optional
- return (an1, mo,it)
+ return (mw, an1, mo,it)
-- ---------------------------------------------------------------------
--
GitLab