From 711b1d24df2f6ef524523097855c735aa116262b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bart=C5=82omiej=20Cie=C5=9Blar?= <bcieslar2001@gmail.com>
Date: Mon, 19 Jun 2023 13:46:08 -0400
Subject: [PATCH] Add support for deprecating exported items (proposal #134)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
This is an implementation of the deprecated exports proposal #134.
The proposal introduces an ability to introduce warnings to exports.
This allows for deprecating a name only when it is exported from a specific
module, rather than always depreacting its usage. In this example:
module A ({-# DEPRECATED "do not use" #-} x) where
x = undefined
---
module B where
import A(x)
`x` will emit a warning when it is explicitly imported.
Like the declaration warnings, export warnings are first accumulated within
the `Warnings` struct, then passed into the ModIface, from which they are
then looked up and warned about in the importing module in the `lookup_ie`
helpers of the `filterImports` function (for the explicitly imported names)
and in the `addUsedGRE(s)` functions where they warn about regular usages
of the imported name.
In terms of the AST information, the custom warning is stored in the
extension field of the variants of the `IE` type (see Trees that Grow for
more information).
The commit includes a bump to the haddock submodule added in MR #28
Signed-off-by: Bartłomiej Cieślar <bcieslar2001@gmail.com>
---
compiler/GHC.hs | 6 +-
compiler/GHC/Driver/Flags.hs | 5 +-
compiler/GHC/Driver/Session.hs | 3 +-
compiler/GHC/Hs/ImpExp.hs | 75 +++-
compiler/GHC/Iface/Make.hs | 6 +-
compiler/GHC/Iface/Recomp.hs | 36 +-
compiler/GHC/Iface/Syntax.hs | 28 +-
compiler/GHC/Parser.y | 54 ++-
compiler/GHC/Parser/PostProcess.hs | 19 +-
compiler/GHC/Rename/Env.hs | 124 ++++--
compiler/GHC/Rename/Module.hs | 10 +-
compiler/GHC/Rename/Names.hs | 79 ++--
compiler/GHC/Rename/Pat.hs | 2 +-
compiler/GHC/Runtime/Loader.hs | 2 +-
compiler/GHC/Tc/Errors/Ppr.hs | 28 +-
compiler/GHC/Tc/Errors/Types.hs | 24 +-
compiler/GHC/Tc/Gen/Export.hs | 353 ++++++++++++++----
compiler/GHC/Tc/Gen/Expr.hs | 4 +-
compiler/GHC/Tc/Instance/Class.hs | 4 +-
compiler/GHC/Tc/Module.hs | 2 +-
compiler/GHC/Tc/Solver/Monad.hs | 3 +-
compiler/GHC/Tc/Utils/Backpack.hs | 8 +-
compiler/GHC/Tc/Utils/Monad.hs | 7 +-
compiler/GHC/Types/Error/Codes.hs | 2 +
compiler/GHC/Types/Hint/Ppr.hs | 2 +-
compiler/GHC/Types/Name/Env.hs | 11 +
compiler/GHC/Types/Name/Reader.hs | 6 +-
compiler/GHC/Unit/Module/ModIface.hs | 20 +-
compiler/GHC/Unit/Module/Warnings.hs | 90 ++++-
docs/users_guide/9.8.1-notes.rst | 22 ++
docs/users_guide/exts/pragmas.rst | 65 +++-
docs/users_guide/using-warnings.rst | 31 ++
.../tests/backpack/cabal/bkpcabal08/Makefile | 21 ++
.../tests/backpack/cabal/bkpcabal08/R.hs | 4 +
.../tests/backpack/cabal/bkpcabal08/Setup.hs | 2 +
.../tests/backpack/cabal/bkpcabal08/all.T | 12 +
.../cabal/bkpcabal08/bkpcabal08.cabal | 30 ++
.../cabal/bkpcabal08/bkpcabal08.stdout | 25 ++
.../tests/backpack/cabal/bkpcabal08/impl/A.hs | 2 +
.../tests/backpack/cabal/bkpcabal08/impl/B.hs | 2 +
.../tests/backpack/cabal/bkpcabal08/p/A.hsig | 3 +
.../tests/backpack/cabal/bkpcabal08/p/B.hsig | 4 +
.../tests/backpack/cabal/bkpcabal08/q/A.hsig | 2 +
.../tests/backpack/cabal/bkpcabal08/q/B.hsig | 2 +
.../tests/backpack/cabal/bkpcabal08/q/M.hs | 4 +
testsuite/tests/backpack/should_compile/all.T | 2 +-
.../tests/backpack/should_compile/bkp44.bkp | 23 --
.../backpack/should_compile/bkp44.stderr | 20 -
.../should_compile/DumpRenamedAst.stderr | 4 +-
.../tests/parser/should_compile/T14189.stderr | 18 +-
testsuite/tests/printer/Makefile | 5 +
testsuite/tests/printer/PprExportWarn.hs | 31 ++
testsuite/tests/printer/all.T | 1 +
.../rename/should_compile/ExportWarnings1.hs | 5 +
.../should_compile/ExportWarnings1.stderr | 30 ++
.../rename/should_compile/ExportWarnings2.hs | 7 +
.../should_compile/ExportWarnings2.stderr | 12 +
.../rename/should_compile/ExportWarnings3.hs | 14 +
.../should_compile/ExportWarnings3.stderr | 37 ++
.../rename/should_compile/ExportWarnings4.hs | 6 +
.../should_compile/ExportWarnings4.stderr | 3 +
.../rename/should_compile/ExportWarnings5.hs | 5 +
.../rename/should_compile/ExportWarnings6.hs | 2 +
.../should_compile/ExportWarnings6.stderr | 7 +
.../should_compile/ExportWarnings_aux.hs | 7 +
.../should_compile/ExportWarnings_aux2.hs | 5 +
.../should_compile/ExportWarnings_base.hs | 14 +
testsuite/tests/rename/should_compile/all.T | 6 +
.../should_fail/DifferentExportWarnings.hs | 17 +
.../DifferentExportWarnings.stderr | 21 ++
.../should_fail/DifferentExportWarningsA.hs | 6 +
testsuite/tests/rename/should_fail/all.T | 1 +
testsuite/tests/showIface/PragmaDocs.hs | 2 +-
testsuite/tests/showIface/PragmaDocs.stdout | 12 +-
utils/check-exact/ExactPrint.hs | 43 ++-
utils/check-exact/Main.hs | 8 +-
utils/haddock | 2 +-
77 files changed, 1256 insertions(+), 364 deletions(-)
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/Makefile
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/R.hs
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/Setup.hs
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/all.T
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.cabal
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/impl/A.hs
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/impl/B.hs
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/p/A.hsig
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/p/B.hsig
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/q/A.hsig
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/q/B.hsig
create mode 100644 testsuite/tests/backpack/cabal/bkpcabal08/q/M.hs
delete mode 100644 testsuite/tests/backpack/should_compile/bkp44.bkp
delete mode 100644 testsuite/tests/backpack/should_compile/bkp44.stderr
create mode 100644 testsuite/tests/printer/PprExportWarn.hs
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings1.hs
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings1.stderr
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings2.hs
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings2.stderr
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings3.hs
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings3.stderr
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings4.hs
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings4.stderr
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings5.hs
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings6.hs
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings6.stderr
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings_aux.hs
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings_aux2.hs
create mode 100644 testsuite/tests/rename/should_compile/ExportWarnings_base.hs
create mode 100644 testsuite/tests/rename/should_fail/DifferentExportWarnings.hs
create mode 100644 testsuite/tests/rename/should_fail/DifferentExportWarnings.stderr
create mode 100644 testsuite/tests/rename/should_fail/DifferentExportWarningsA.hs
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 66432aa16343..cb4ba5f1e984 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -1419,7 +1419,7 @@ getPackageModuleInfo hsc_env mdl
tys = [ ty | name <- concatMap availNames avails,
Just ty <- [lookupTypeEnv pte name] ]
- let !rdr_env = availsToGlobalRdrEnv hsc_env (moduleName mdl) avails
+ let !rdr_env = availsToGlobalRdrEnv hsc_env mdl avails
-- See Note [Forcing GREInfo] in GHC.Types.GREInfo.
return (Just (ModuleInfo {
@@ -1432,7 +1432,7 @@ getPackageModuleInfo hsc_env mdl
minf_modBreaks = emptyModBreaks
}))
-availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> ModuleName -> [AvailInfo] -> IfGlobalRdrEnv
+availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv
availsToGlobalRdrEnv hsc_env mod avails
= forceGlobalRdrEnv rdr_env
-- See Note [Forcing GREInfo] in GHC.Types.GREInfo.
@@ -1441,7 +1441,7 @@ availsToGlobalRdrEnv hsc_env mod avails
-- We're building a GlobalRdrEnv as if the user imported
-- all the specified modules into the global interactive module
imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
- decl = ImpDeclSpec { is_mod = mod, is_as = mod,
+ decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod,
is_qual = False,
is_dloc = srcLocSpan interactiveSrcLoc }
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index e06d6e9d1810..fec6508b6d68 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -647,6 +647,7 @@ data WarningFlag =
| Opt_WarnTermVariableCapture -- Since 9.8
| Opt_WarnMissingRoleAnnotations -- Since 9.8
| Opt_WarnImplicitRhsQuantification -- Since 9.8
+ | Opt_WarnIncompleteExportWarnings -- Since 9.8
deriving (Eq, Ord, Show, Enum)
-- | Return the names of a WarningFlag
@@ -756,6 +757,7 @@ warnFlagNames wflag = case wflag of
Opt_WarnTypeEqualityRequiresOperators -> "type-equality-requires-operators" :| []
Opt_WarnMissingRoleAnnotations -> "missing-role-annotations" :| []
Opt_WarnImplicitRhsQuantification -> "implicit-rhs-quantification" :| []
+ Opt_WarnIncompleteExportWarnings -> "incomplete-export-warnings" :| []
-- -----------------------------------------------------------------------------
-- Standard sets of warning options
@@ -928,7 +930,8 @@ minusWallOpts
Opt_WarnUnusedRecordWildcards,
Opt_WarnRedundantRecordWildcards,
Opt_WarnIncompleteUniPatterns,
- Opt_WarnIncompletePatternsRecUpd
+ Opt_WarnIncompletePatternsRecUpd,
+ Opt_WarnIncompleteExportWarnings
]
-- | Things you get with -Weverything, i.e. *all* known warnings flags
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index f7c32113debb..6331774b3f67 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -2271,7 +2271,8 @@ wWarningFlagsDeps = mconcat [
warnSpec Opt_WarnTypeEqualityRequiresOperators,
warnSpec Opt_WarnTermVariableCapture,
warnSpec Opt_WarnMissingRoleAnnotations,
- warnSpec Opt_WarnImplicitRhsQuantification
+ warnSpec Opt_WarnImplicitRhsQuantification,
+ warnSpec Opt_WarnIncompleteExportWarnings
]
warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]
diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs
index 06a6cc783ea4..5e25893cb962 100644
--- a/compiler/GHC/Hs/ImpExp.hs
+++ b/compiler/GHC/Hs/ImpExp.hs
@@ -38,6 +38,8 @@ import GHC.Hs.Extension
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Unit.Module.Warnings (WarningTxt)
+
import Data.Data
import Data.Maybe
@@ -198,16 +200,39 @@ type instance Anno (IEWrappedName (GhcPass _)) = SrcSpanAnnA
type instance Anno (IE (GhcPass p)) = SrcSpanAnnA
-type instance XIEVar GhcPs = NoExtField
-type instance XIEVar GhcRn = NoExtField
-type instance XIEVar GhcTc = NoExtField
-
-type instance XIEThingAbs (GhcPass _) = EpAnn [AddEpAnn]
-type instance XIEThingAll (GhcPass _) = EpAnn [AddEpAnn]
-type instance XIEThingWith (GhcPass _) = EpAnn [AddEpAnn]
-
-type instance XIEModuleContents GhcPs = EpAnn [AddEpAnn]
-type instance XIEModuleContents GhcRn = 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 XIEVar GhcPs = Maybe (LocatedP (WarningTxt GhcPs))
+type instance XIEVar GhcRn = Maybe (LocatedP (WarningTxt 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 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 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 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 GhcTc = NoExtField
type instance XIEGroup (GhcPass _) = NoExtField
@@ -236,6 +261,22 @@ ieNames (IEGroup {}) = []
ieNames (IEDoc {}) = []
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 GhcPs (IEVar xie _) = xie
+ ie_deprecation GhcPs (IEThingAbs (xie, _) _) = xie
+ ie_deprecation GhcPs (IEThingAll (xie, _) _) = xie
+ ie_deprecation GhcPs (IEThingWith (xie, _) _ _ _) = xie
+ ie_deprecation GhcPs (IEModuleContents (xie, _) _) = xie
+ ie_deprecation GhcRn (IEVar xie _) = xie
+ ie_deprecation GhcRn (IEThingAbs (xie, _) _) = xie
+ ie_deprecation GhcRn (IEThingAll (xie, _) _) = xie
+ ie_deprecation GhcRn (IEThingWith (xie, _) _ _ _) = xie
+ ie_deprecation GhcRn (IEModuleContents xie _) = xie
+ ie_deprecation _ _ = Nothing
+
ieWrappedLName :: IEWrappedName (GhcPass p) -> LIdP (GhcPass p)
ieWrappedLName (IEName _ (L l n)) = L l n
ieWrappedLName (IEPattern _ (L l n)) = L l n
@@ -260,11 +301,11 @@ replaceLWrappedName :: LIEWrappedName GhcPs -> IdP GhcRn -> LIEWrappedName GhcRn
replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n')
instance OutputableBndrId p => Outputable (IE (GhcPass p)) where
- ppr (IEVar _ var) = ppr (unLoc var)
- ppr (IEThingAbs _ thing) = ppr (unLoc thing)
- ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"]
- ppr (IEThingWith _ thing wc withs)
- = ppr (unLoc thing) <> parens (fsep (punctuate comma ppWiths))
+ ppr ie@(IEVar _ var) = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ ppr (unLoc var)]
+ ppr ie@(IEThingAbs _ thing) = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ ppr (unLoc thing)]
+ ppr ie@(IEThingAll _ thing) = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ hcat [ppr (unLoc thing), text "(..)"]]
+ ppr ie@(IEThingWith _ thing wc withs)
+ = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ ppr (unLoc thing) <> parens (fsep (punctuate comma ppWiths))]
where
ppWiths =
case wc of
@@ -273,8 +314,8 @@ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where
IEWildcard pos ->
let (bs, as) = splitAt pos (map (ppr . unLoc) withs)
in bs ++ [text ".."] ++ as
- ppr (IEModuleContents _ mod')
- = text "module" <+> ppr mod'
+ ppr ie@(IEModuleContents _ mod')
+ = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ text "module" <+> ppr mod']
ppr (IEGroup _ n _) = text ("<IEGroup: " ++ show n ++ ">")
ppr (IEDoc _ doc) = ppr doc
ppr (IEDocNamed _ string) = text ("<IEDocNamed: " ++ string ++ ">")
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index dd84d399f59b..2dc05841f78d 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -396,9 +396,11 @@ ifaceRoughMatchTcs tcs = map do_rough tcs
--------------------------
toIfaceWarnings :: Warnings GhcRn -> IfaceWarnings
-toIfaceWarnings NoWarnings = IfNoWarnings
toIfaceWarnings (WarnAll txt) = IfWarnAll (toIfaceWarningTxt txt)
-toIfaceWarnings (WarnSome prs) = IfWarnSome [(occ, toIfaceWarningTxt txt) | (occ, txt) <- prs]
+toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds'
+ where
+ vs' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- vs]
+ ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds]
toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt
toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc <$> mb_cat) (unLoc src) (map (toIfaceStringLiteralWithNames . unLoc) strs)
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 48b24b903b78..da47ecd8d59f 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -964,7 +964,8 @@ addFingerprints hsc_env iface0
eps <- hscEPS hsc_env
let
decls = mi_decls iface0
- warn_fn = mkIfaceWarnCache (fromIfaceWarnings $ mi_warns iface0)
+ decl_warn_fn = mkIfaceDeclWarnCache (fromIfaceWarnings $ mi_warns iface0)
+ export_warn_fn = mkIfaceExportWarnCache (fromIfaceWarnings $ mi_warns iface0)
fix_fn = mkIfaceFixCache (mi_fixities iface0)
-- The ABI of a declaration represents everything that is made
@@ -1265,22 +1266,23 @@ addFingerprints hsc_env iface0
let
final_iface_exts = ModIfaceBackend
- { mi_iface_hash = iface_hash
- , mi_mod_hash = mod_hash
- , mi_flag_hash = flag_hash
- , mi_opt_hash = opt_hash
- , mi_hpc_hash = hpc_hash
- , mi_plugin_hash = plugin_hash
- , mi_orphan = not ( all ifRuleAuto orph_rules
- -- See Note [Orphans and auto-generated rules]
- && null orph_insts
- && null orph_fis)
- , mi_finsts = not (null (mi_fam_insts iface0))
- , mi_exp_hash = export_hash
- , mi_orphan_hash = orphan_hash
- , mi_warn_fn = warn_fn
- , mi_fix_fn = fix_fn
- , mi_hash_fn = lookupOccEnv local_env
+ { mi_iface_hash = iface_hash
+ , mi_mod_hash = mod_hash
+ , mi_flag_hash = flag_hash
+ , mi_opt_hash = opt_hash
+ , mi_hpc_hash = hpc_hash
+ , mi_plugin_hash = plugin_hash
+ , mi_orphan = not ( all ifRuleAuto orph_rules
+ -- See Note [Orphans and auto-generated rules]
+ && null orph_insts
+ && null orph_fis)
+ , mi_finsts = not (null (mi_fam_insts iface0))
+ , mi_exp_hash = export_hash
+ , mi_orphan_hash = orphan_hash
+ , mi_decl_warn_fn = decl_warn_fn
+ , mi_export_warn_fn = export_warn_fn
+ , mi_fix_fn = fix_fn
+ , mi_hash_fn = lookupOccEnv local_env
}
final_iface = iface0 { mi_decls = sorted_decls, mi_extra_decls = sorted_extra_decls, mi_final_exts = final_iface_exts }
--
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 39579b69b2b8..84716f9ad32e 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -345,9 +345,9 @@ data IfaceRule
}
data IfaceWarnings
- = IfNoWarnings
- | IfWarnAll IfaceWarningTxt
+ = IfWarnAll IfaceWarningTxt
| IfWarnSome [(OccName, IfaceWarningTxt)]
+ [(IfExtName, IfaceWarningTxt)]
data IfaceWarningTxt
= IfWarningTxt (Maybe WarningCategory) SourceText [(IfaceStringLiteral, [IfExtName])]
@@ -584,9 +584,9 @@ ifaceDeclFingerprints hash decl
fromIfaceWarnings :: IfaceWarnings -> Warnings GhcRn
fromIfaceWarnings = \case
- IfNoWarnings -> NoWarnings
IfWarnAll txt -> WarnAll (fromIfaceWarningTxt txt)
- IfWarnSome prs -> WarnSome [(occ, fromIfaceWarningTxt txt) | (occ, txt) <- prs]
+ IfWarnSome vs ds -> WarnSome [(occ, fromIfaceWarningTxt txt) | (occ, txt) <- vs]
+ [(occ, fromIfaceWarningTxt txt) | (occ, txt) <- ds]
fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
fromIfaceWarningTxt = \case
@@ -753,9 +753,11 @@ pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs
instance Outputable IfaceWarnings where
ppr = \case
- IfNoWarnings -> empty
IfWarnAll txt -> text "Warn all" <+> ppr txt
- IfWarnSome prs -> text "Warnings:" <+> vcat [ppr name <+> ppr txt | (name, txt) <- prs]
+ IfWarnSome vs ds ->
+ hang (text "Warnings:") 2 $
+ text "Deprecated names:" <+> vcat [ppr name <+> ppr txt | (name, txt) <- vs] $$
+ text "Deprecated exports:" <+> vcat [ppr name <+> ppr txt | (name, txt) <- ds]
instance Outputable IfaceWarningTxt where
ppr = \case
@@ -2322,13 +2324,12 @@ instance Binary IfaceRule where
instance Binary IfaceWarnings where
put_ bh = \case
- IfNoWarnings -> putByte bh 0
- IfWarnAll txt -> putByte bh 1 *> put_ bh txt
- IfWarnSome prs -> putByte bh 2 *> put_ bh prs
+ IfWarnAll txt -> putByte bh 0 *> put_ bh txt
+ IfWarnSome vs ds -> putByte bh 1 *> put_ bh vs *> put_ bh ds
get bh = getByte bh >>= \case
- 0 -> pure IfNoWarnings
- 1 -> pure IfWarnAll <*> get bh
- _ -> pure IfWarnSome <*> get bh
+ 0 -> pure IfWarnAll <*> get bh
+ 1 -> pure IfWarnSome <*> get bh <*> get bh
+ _ -> fail "invalid tag(IfaceWarnings)"
instance Binary IfaceWarningTxt where
put_ bh = \case
@@ -2901,9 +2902,8 @@ instance NFData IfaceClsInst where
instance NFData IfaceWarnings where
rnf = \case
- IfNoWarnings -> ()
IfWarnAll txt -> rnf txt
- IfWarnSome txts -> rnf txts
+ IfWarnSome vs ds -> rnf vs `seq` rnf ds
instance NFData IfaceWarningTxt where
rnf = \case
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index a61a1335743c..37844ff46f97 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1026,11 +1026,24 @@ exportlist1 :: { OrdList (LIE GhcPs) }
-- No longer allow things like [] and (,,,) to be exported
-- They are built in syntax, always available
export :: { OrdList (LIE GhcPs) }
- : qcname_ext export_subspec {% mkModuleImpExp (fst $ unLoc $2) $1 (snd $ unLoc $2)
- >>= \ie -> fmap (unitOL . reLocA) (return (sLL (reLoc $1) $> ie)) }
- | 'module' modid {% fmap (unitOL . reLocA) (acs (\cs -> sLL $1 (reLoc $>) (IEModuleContents (EpAnn (glR $1) [mj AnnModule $1] cs) $2))) }
- | 'pattern' qcon { unitOL (reLocA (sLL $1 (reLocN $>)
- (IEVar noExtField (sLLa $1 (reLocN $>) (IEPattern (glAA $1) $2))))) }
+ : maybeexportwarning qcname_ext export_subspec {% do { let { span = (maybe comb2 (comb3 . reLoc) $1) (reLoc $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 . reLoc) $1) $2 (reLoc $>)
+ ; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 (reLoc 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 . reLoc) $1) $2 (reLoc $>)
+ in unitOL $ reLocA $ sL span $ IEVar $1 (sLLa $2 (reLocN $>) (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) }
@@ -1166,13 +1179,40 @@ maybeimpspec :: { Located (Maybe (ImportListInterpretation, LocatedL [LIE GhcPs]
| {- empty -} { noLoc Nothing }
impspec :: { Located (ImportListInterpretation, LocatedL [LIE GhcPs]) }
- : '(' exportlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2)
+ : '(' importlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2)
(AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) [])
; return $ sLL $1 $> (Exactly, es)} }
- | 'hiding' '(' exportlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $3)
+ | 'hiding' '(' importlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $3)
(AnnList Nothing (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) [])
; return $ sLL $1 $> (EverythingBut, es)} }
+importlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) }
+ : importlist1 { ([], $1) }
+ | {- empty -} { ([], nilOL) }
+
+ -- trailing comma:
+ | importlist1 ',' {% case $1 of
+ SnocOL hs t -> do
+ t' <- addTrailingCommaA t (gl $2)
+ return ([], snocOL hs t')}
+ | ',' { ([mj AnnComma $1], nilOL) }
+
+importlist1 :: { OrdList (LIE GhcPs) }
+ : importlist1 ',' import
+ {% let ls = $1
+ in if isNilOL ls
+ then return (ls `appOL` $3)
+ else case ls of
+ SnocOL hs t -> do
+ t' <- addTrailingCommaA t (gl $2)
+ return (snocOL hs t' `appOL` $3)}
+ | import { $1 }
+
+import :: { OrdList (LIE GhcPs) }
+ : qcname_ext export_subspec {% fmap (unitOL . reLocA . (sLL (reLoc $1) $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) }
+ | 'module' modid {% fmap (unitOL . reLocA) $ acs (\cs -> sLL $1 (reLoc $>) (IEModuleContents (Nothing, EpAnn (glR $1) [mj AnnModule $1] cs) $2)) }
+ | 'pattern' qcon { unitOL $ reLocA $ sLL $1 (reLocN $>) $ IEVar Nothing (sLLa $1 (reLocN $>) (IEPattern (glAA $1) $2)) }
+
-----------------------------------------------------------------------------
-- Fixity Declarations
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index c5bc296441c5..d37744ab4136 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -153,6 +153,7 @@ import Data.Either
import Data.List ( findIndex )
import Data.Foldable
import qualified Data.Semigroup as Semi
+import GHC.Unit.Module.Warnings
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import qualified GHC.Data.Strict as Strict
@@ -2791,18 +2792,20 @@ data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)
| ImpExpQcType EpaLocation (LocatedN RdrName)
| ImpExpQcWildcard
-mkModuleImpExp :: [AddEpAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
-mkModuleImpExp anns (L l specname) subs = do
+mkModuleImpExp :: Maybe (LocatedP (WarningTxt 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
- let ann = EpAnn (spanAsAnchor $ locA l) anns cs
+ let ann = EpAnn (spanAsAnchor $ maybe (locA l) getLocA warning) anns cs
case subs of
ImpExpAbs
| isVarNameSpace (rdrNameSpace name)
- -> return $ IEVar noExtField (L l (ieNameFromSpec specname))
- | otherwise -> IEThingAbs ann . L l <$> nameT
- ImpExpAll -> IEThingAll ann . L l <$> nameT
+ -> return $ IEVar warning
+ (L l (ieNameFromSpec specname))
+ | otherwise -> IEThingAbs (warning, ann) . L l <$> nameT
+ ImpExpAll -> IEThingAll (warning, ann) . L l <$> nameT
ImpExpList xs ->
- (\newName -> IEThingWith ann (L l newName)
+ (\newName -> IEThingWith (warning, ann) (L l newName)
NoIEWildcard (wrapped xs)) <$> nameT
ImpExpAllWith xs ->
do allowed <- getBit PatternSynonymsBit
@@ -2814,7 +2817,7 @@ mkModuleImpExp anns (L l specname) subs = do
ies :: [LocatedA (IEWrappedName GhcPs)]
ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs
in (\newName
- -> IEThingWith ann (L l newName) pos ies)
+ -> IEThingWith (warning, ann) (L l newName) pos ies)
<$> nameT
else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
PsErrIllegalPatSynExport
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index ab70fe462c3f..50ad92b792ce 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -2,7 +2,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TupleSections #-}
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-2006
@@ -79,7 +79,7 @@ import GHC.Parser.PostProcess ( setRdrNameSpace )
import GHC.Builtin.Types
import GHC.Types.Name
import GHC.Types.Name.Set
-import GHC.Types.Name.Env ( lookupNameEnv )
+import GHC.Types.Name.Env
import GHC.Types.Avail
import GHC.Types.Hint
import GHC.Types.Error
@@ -116,6 +116,7 @@ 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 )
@@ -408,7 +409,7 @@ lookupInstDeclBndr cls what rdr
-- to use a qualified name for the method
-- (Although it'd make perfect sense.)
; mb_name <- lookupSubBndrOcc
- DisableDeprecationWarnings
+ NoDeprecationWarnings
-- we don't give deprecated
-- warnings when a deprecated class
-- method is defined. We only warn
@@ -554,7 +555,7 @@ lookupRecFieldOcc mb_con rdr_name
, text "rdr_name:" <+> ppr rdr_name
, text "flds:" <+> ppr flds
, text "mb_gre:" <+> ppr mb_gre ]
- ; mapM_ (addUsedGRE EnableDeprecationWarnings) mb_gre
+ ; mapM_ (addUsedGRE AllDeprecationWarnings) mb_gre
; return $ flSelector . fieldGRELabel <$> mb_gre }
; case mb_nm of
{ Nothing -> do { addErr (badFieldConErr con lbl)
@@ -1415,7 +1416,7 @@ lookupFieldGREs env (L loc rdr)
lookupGlobalOccRn_overloaded :: RdrName -> RnM (Maybe GlobalRdrElt)
lookupGlobalOccRn_overloaded rdr_name =
lookupExactOrOrig_maybe rdr_name id $
- do { res <- lookupGreRn_helper (IncludeFields WantNormal) rdr_name EnableDeprecationWarnings
+ do { res <- lookupGreRn_helper (IncludeFields WantNormal) rdr_name AllDeprecationWarnings
; case res of
GreNotFound -> lookupOneQualifiedNameGHCi WantNormal rdr_name
OneNameMatch gre -> return $ Just gre
@@ -1635,7 +1636,7 @@ lookupGreRn_maybe :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt)
-- Uses addUsedRdrName to record use and deprecations
lookupGreRn_maybe which_gres rdr_name
= do
- res <- lookupGreRn_helper which_gres rdr_name EnableDeprecationWarnings
+ res <- lookupGreRn_helper which_gres rdr_name AllDeprecationWarnings
case res of
OneNameMatch gre -> return $ Just gre
MultipleNames gres -> do
@@ -1688,7 +1689,7 @@ lookupGreAvailRn :: RdrName -> RnM (Maybe GlobalRdrElt)
-- Uses addUsedRdrName to record use and deprecations
lookupGreAvailRn rdr_name
= do
- mb_gre <- lookupGreRn_helper (IncludeFields WantNormal) rdr_name DisableDeprecationWarnings
+ mb_gre <- lookupGreRn_helper (IncludeFields WantNormal) rdr_name ExportDeprecationWarnings
case mb_gre of
GreNotFound ->
do
@@ -1713,7 +1714,7 @@ lookupGreAvailRn rdr_name
Note [Handling of deprecations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* We report deprecations at each *occurrence* of the deprecated thing
- (see #5867)
+ (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
@@ -1721,6 +1722,10 @@ Note [Handling of deprecations]
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(..)'
@@ -1730,39 +1735,43 @@ Note [Handling of deprecations]
addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM ()
-- Remember use of in-scope data constructors (#7969)
addUsedDataCons rdr_env tycon
- = addUsedGREs [ gre
- | dc <- tyConDataCons tycon
- , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ]
+ = addUsedGREs NoDeprecationWarnings
+ [ gre
+ | 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
- = DisableDeprecationWarnings
- | EnableDeprecationWarnings
+ = 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 { case warn_if_deprec of
- EnableDeprecationWarnings -> warnIfDeprecated gre
- DisableDeprecationWarnings -> return ()
+ = do { condWarnIfDeprecated warn_if_deprec [gre]
; when (isImportedGRE gre) $ -- See Note [Using isImportedGRE in addUsedGRE]
do { env <- getGblEnv
-- Do not report the GREInfo (#23424)
; traceRn "addUsedGRE" (ppr $ greName gre)
; updTcRef (tcg_used_gres env) (gre :) } }
-addUsedGREs :: [GlobalRdrElt] -> RnM ()
+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]
-addUsedGREs gres
- | null imp_gres = return ()
- | otherwise = do { env <- getGblEnv
- -- Do not report the GREInfo (#23424)
- ; traceRn "addUsedGREs"
- (ppr $ map greName imp_gres)
- ; updTcRef (tcg_used_gres env) (imp_gres ++) }
+addUsedGREs warn_if_deprec gres
+ = do { condWarnIfDeprecated warn_if_deprec gres
+ ; unless (null imp_gres) $
+ do { env <- getGblEnv
+ -- Do not report the GREInfo (#23424)
+ ; traceRn "addUsedGREs" (ppr $ map greName imp_gres)
+ ; updTcRef (tcg_used_gres env) (imp_gres ++) } }
where
imp_gres = filter isImportedGRE gres
-- See Note [Using isImportedGRE in addUsedGRE]
@@ -1781,22 +1790,32 @@ 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.
-}
-warnIfDeprecated :: GlobalRdrElt -> RnM ()
-warnIfDeprecated gre@(GRE { gre_imp = iss })
+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
- ; this_mod <- getModule
- ; when (wopt_any_custom dflags &&
- not (nameIsLocalOrFrom this_mod name)) $
+ ; when (wopt_any_custom dflags) $
-- See Note [Handling of deprecations]
do { iface <- loadInterfaceForName doc name
- ; case lookupImpDeprec iface gre of
+ ; 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 = definedMod
+ pragma_warning_defined_mod = Just definedMod
}
Nothing -> return () } }
| otherwise
@@ -1807,13 +1826,35 @@ warnIfDeprecated gre@(GRE { gre_imp = iss })
definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name)
doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly"
-lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn)
-lookupImpDeprec iface gre
- = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing,
+lookupImpDeclDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn)
+lookupImpDeclDeprec iface gre
+ = mi_decl_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing,
case gre_par gre of -- or its parent, is warn'd
- ParentIs p -> mi_warn_fn (mi_final_exts iface) (nameOccName p)
+ 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 {
+ pragma_warning_occ = occ,
+ pragma_warning_msg = warn_txt,
+ pragma_warning_import_mod = importing_mod,
+ pragma_warning_defined_mod = Nothing
+ } }
+ 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1902,12 +1943,12 @@ lookupQualifiedNameGHCi fos rdr_name
where
go_for_it dflags is_ghci
- | Just (mod,occ) <- isQual_maybe rdr_name
+ | Just (mod_name,occ) <- isQual_maybe rdr_name
, let ns = occNameSpace occ
, is_ghci
, gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour
, not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi]
- = do { res <- loadSrcInterface_maybe doc mod NotBoot NoPkgQual
+ = do { res <- loadSrcInterface_maybe doc mod_name NotBoot NoPkgQual
; case res of
Succeeded iface
-> do { hsc_env <- getTopEnv
@@ -1919,7 +1960,8 @@ lookupQualifiedNameGHCi fos rdr_name
lk_ns = occNameSpace lk_occ
, occNameFS occ == occNameFS lk_occ
, ns == lk_ns || (ns == varName && isFieldNameSpace lk_ns)
- , let gre = lookupGRE_PTE mod hsc_env gname
+ , let mod = mi_module iface
+ gre = lookupGRE_PTE mod hsc_env gname
, allowGRE fos gre
-- Include a field if it has a selector or we are looking for all fields;
-- see Note [NoFieldSelectors].
@@ -1939,7 +1981,7 @@ lookupQualifiedNameGHCi fos rdr_name
-- Lookup a Name for an implicit qualified import in GHCi
-- in the given PackageTypeEnv.
- lookupGRE_PTE :: ModuleName -> HscEnv -> Name -> GlobalRdrElt
+ lookupGRE_PTE :: Module -> HscEnv -> Name -> GlobalRdrElt
lookupGRE_PTE mod hsc_env nm =
-- Fake a GRE so we can report a sensible name clash error if
-- -fimplicit-import-qualified is used with a module that exports the same
@@ -1952,7 +1994,7 @@ lookupQualifiedNameGHCi fos rdr_name
, gre_info = info }
where
info = lookupGREInfo hsc_env nm
- spec = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, is_dloc = noSrcSpan }
+ spec = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, is_qual = True, is_dloc = noSrcSpan }
is = ImpSpec { is_decl = spec, is_item = ImpAll }
-- | Look up the 'GREInfo' associated with the given 'Name'
@@ -2098,7 +2140,7 @@ lookupBindGroupOcc ctxt what rdr_name
else lookup_top (`elemNameSet` ns)
where
lookup_cls_op cls
- = lookupSubBndrOcc EnableDeprecationWarnings cls doc rdr_name
+ = lookupSubBndrOcc AllDeprecationWarnings cls doc rdr_name
where
doc = text "method of class" <+> quotes (ppr cls)
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index d7a5fa483324..ebc9f4720c26 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -194,7 +194,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- Rename deprec decls;
-- check for duplicates and ensure that deprecated things are defined locally
-- at the moment, we don't keep these around past renaming
- rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
+ rn_decl_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
-- (H) Rename Everything else
@@ -236,7 +236,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
in -- we return the deprecs in the env, not in the HsGroup above
- tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
+ tcg_env' { tcg_warns = insertWarnDecls (tcg_warns tcg_env') rn_decl_warns };
} ;
traceRn "finish rnSrc" (ppr rn_group) ;
traceRn "finish Dus" (ppr src_dus ) ;
@@ -266,9 +266,9 @@ gather them together.
-}
-- checks that the deprecations are defined locally, and that there are no duplicates
-rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn)
+rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (DeclWarnOccNames GhcRn)
rnSrcWarnDecls _ []
- = return NoWarnings
+ = return []
rnSrcWarnDecls bndr_set decls'
= do { -- check for duplicates
@@ -276,7 +276,7 @@ rnSrcWarnDecls bndr_set decls'
in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr))
warn_rdr_dups
; pairs_s <- mapM (addLocMA rn_deprec) decls
- ; return (WarnSome ((concat pairs_s))) }
+ ; return $ concat pairs_s }
where
decls = concatMap (wd_warnings . unLoc) decls'
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 79df35d19e80..503700d8d878 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -387,9 +387,9 @@ rnImportDecl this_mod
when (mod_safe && not (safeImportsOn dflags)) $
addErr (TcRnSafeImportsDisabled imp_mod_name)
- let
+ let imp_mod = mi_module iface
qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name
- imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,
+ imp_spec = ImpDeclSpec { is_mod = imp_mod, is_qual = qual_only,
is_dloc = locA loc, is_as = qual_mod_name }
-- filter the imports according to the import declaration
@@ -621,7 +621,6 @@ warnUnqualifiedImport decl iface =
-- Modules for which we warn if we see unqualified imports
qualifiedMods = mkModuleSet [ dATA_LIST ]
-
{-
************************************************************************
* *
@@ -1193,6 +1192,7 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
return (Just (want_hiding, L l (map fst items2)), gres)
where
+ import_mod = mi_module iface
all_avails = mi_exports iface
hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
imp_occ_env = mkImportOccEnv hsc_env decl_spec all_avails
@@ -1254,6 +1254,13 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
-- 'badImportItemErr'.
reason <- badImportItemErr iface decl_spec ie BadImportIsParent 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
+ })
run_lookup :: IELookupM a -> TcRn (Maybe a)
run_lookup m = case m of
@@ -1283,15 +1290,20 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
IEVar _ (L l n) -> do
-- See Note [Importing DuplicateRecordFields]
xs <- lookup_names ie (ieWrappedName n)
- return ( [ (IEVar noExtField (L l (replaceWrappedName n name)), [gre])
- | ImpOccItem { imp_item = gre } <- NE.toList xs
+ let gres = map imp_item $ NE.toList xs
+ export_depr_warns
+ | want_hiding == Exactly
+ = mapMaybe mk_depr_export_warning gres
+ | otherwise = []
+ return ( [ (IEVar Nothing (L l (replaceWrappedName n name)), [gre])
+ | gre <- gres
, let name = greName gre ]
- , [] )
+ , export_depr_warns )
IEThingAll _ (L l tc) -> do
ImpOccItem gre child_gres _ <- lookup_parent ie $ ieWrappedName tc
let name = greName gre
- warns
+ imp_list_warn
| null child_gres
-- e.g. f(..) or T(..) where T is a type synonym
@@ -1304,9 +1316,17 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
| otherwise
= []
- renamed_ie = IEThingAll noAnn (L l (replaceWrappedName tc name))
+ renamed_ie = IEThingAll (Nothing, noAnn) (L l (replaceWrappedName tc name))
+ export_depr_warn
+ | want_hiding == Exactly
+ = maybeToList $ mk_depr_export_warning gre
+ -- We don't want to warn about the children as they
+ -- are not explicitly mentioned; the warning will
+ -- be emitted later on if they are used
+ | otherwise = []
- return ([(renamed_ie, gre:child_gres)], warns)
+ return ( [(renamed_ie, gre:child_gres)]
+ , imp_list_warn ++ export_depr_warn)
IEThingAbs _ (L l tc')
@@ -1319,33 +1339,38 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
in
case catIELookupM [ tc_name, dc_name ] of
[] -> failLookupWith (BadImport ie BadImportIsParent)
- names -> return ([mkIEThingAbs tc' l (imp_item name) | name <- names], [])
+ names -> return ( [mkIEThingAbs tc' l (imp_item name) | name <- names], [])
| otherwise
-> do ImpOccItem { imp_item = gre } <- lookup_parent ie (ieWrappedName tc')
- return ([mkIEThingAbs tc' l gre], [])
+ return ( [mkIEThingAbs tc' l gre]
+ , maybeToList $ mk_depr_export_warning gre)
- IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns -> do
+ IEThingWith (deprecation, ann) ltc@(L l rdr_tc) wc rdr_ns -> do
ImpOccItem { imp_item = gre, imp_bundled = subnames }
- <- lookup_parent (IEThingAbs noAnn ltc) (ieWrappedName rdr_tc)
+ <- lookup_parent (IEThingAbs (Nothing, noAnn) ltc) (ieWrappedName rdr_tc)
let name = greName gre
-- Look up the children in the sub-names of the parent
-- See Note [Importing DuplicateRecordFields]
case lookupChildren subnames rdr_ns of
- Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs) BadImportIsSubordinate)
+ Failed rdrs -> failLookupWith (BadImport (IEThingWith (deprecation, ann) ltc wc rdrs ) BadImportIsSubordinate)
-- We are trying to import T( a,b,c,d ), and failed
-- to find 'b' and 'd'. So we make up an import item
-- to report as failing, namely T( b, d ).
-- c.f. #15412
Succeeded childnames ->
- return ([ (IEThingWith xt (L l name') wc childnames'
- ,gre : map unLoc childnames)]
- , [])
+ return ([ (IEThingWith (Nothing, ann) (L l name') wc childnames'
+ ,gres)]
+ , export_depr_warns)
where name' = replaceWrappedName rdr_tc name
childnames' = map (to_ie_post_rn . fmap greName) childnames
+ gres = gre : map unLoc childnames
+ export_depr_warns
+ | want_hiding == Exactly = mapMaybe mk_depr_export_warning gres
+ | otherwise = []
_other -> failLookupWith IllegalImport
-- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed...
@@ -1353,19 +1378,25 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
where
mkIEThingAbs tc l gre
- = (IEThingAbs noAnn (L l (replaceWrappedName tc n)), [gre])
+ = (IEThingAbs (Nothing, noAnn) (L l (replaceWrappedName tc n)), [gre])
where n = greName gre
handle_bad_import m = catchIELookup m $ \err -> case err of
BadImport ie _ | want_hiding == EverythingBut -> return ([], [BadImportW ie])
_ -> failLookupWith err
+ mk_depr_export_warning gre
+ = DeprecatedExport name <$> mi_export_warn_fn (mi_final_exts iface) name
+ where
+ name = greName gre
+
type IELookupM = MaybeErr IELookupError
data IELookupWarning
= BadImportW (IE GhcPs)
| MissingImportList
| DodgyImport GlobalRdrElt
+ | DeprecatedExport Name (WarningTxt GhcRn)
data BadImportIsSubordinate = BadImportIsParent | BadImportIsSubordinate
@@ -1947,10 +1978,10 @@ getMinimalImports ie_decls
to_ie rdr_env _ (Avail c) -- Note [Overloaded field import]
= do { let
gre = expectJust "getMinimalImports Avail" $ lookupGRE_Name rdr_env c
- ; return $ [IEVar noExtField (to_ie_post_rn $ noLocA $ greName gre)] }
+ ; return $ [IEVar Nothing (to_ie_post_rn $ noLocA $ greName gre)] }
to_ie _ _ avail@(AvailTC n [_]) -- Exporting the main decl and nothing else
| availExportsDecl avail
- = return [IEThingAbs noAnn (to_ie_post_rn $ noLocA n)]
+ = return [IEThingAbs (Nothing, noAnn) (to_ie_post_rn $ noLocA n)]
to_ie rdr_env iface (AvailTC n cs) =
case [ xs | avail@(AvailTC x xs) <- mi_exports iface
, x == n
@@ -1958,11 +1989,11 @@ getMinimalImports ie_decls
] of
[xs]
| all_used xs
- -> return [IEThingAll noAnn (to_ie_post_rn $ noLocA n)]
+ -> return [IEThingAll (Nothing, noAnn) (to_ie_post_rn $ noLocA n)]
| otherwise
-> do { let ns_gres = map (expectJust "getMinimalImports AvailTC" . lookupGRE_Name rdr_env) cs
ns = map greName ns_gres
- ; return [IEThingWith noAnn (to_ie_post_rn $ noLocA n) NoIEWildcard
+ ; return [IEThingWith (Nothing, noAnn) (to_ie_post_rn $ noLocA n) NoIEWildcard
(map (to_ie_post_rn . noLocA) (filter (/= n) ns))] }
-- Note [Overloaded field import]
_other
@@ -1972,8 +2003,8 @@ getMinimalImports ie_decls
fs = map fieldGREInfo fs_gres
; return $
if all_non_overloaded fs
- then map (IEVar noExtField . to_ie_post_rn_var . noLocA) ns
- else [IEThingWith noAnn (to_ie_post_rn $ noLocA n) NoIEWildcard
+ then map (IEVar Nothing . to_ie_post_rn_var . noLocA) ns
+ else [IEThingWith (Nothing, noAnn) (to_ie_post_rn $ noLocA n) NoIEWildcard
(map (to_ie_post_rn . noLocA) (filter (/= n) ns))] }
where
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 7ee4b09a851c..312629c0fad4 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -830,7 +830,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
HsRecFieldCon {} -> arg_in_scope lbl
_other -> True ]
- ; addUsedGREs dot_dot_gres
+ ; addUsedGREs NoDeprecationWarnings dot_dot_gres
; let locn = noAnnSrcSpan loc
; return [ L (noAnnSrcSpan loc) (HsFieldBind
{ hfbAnn = noAnn
diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs
index 3137195864f3..e7fd7a9022d9 100644
--- a/compiler/GHC/Runtime/Loader.hs
+++ b/compiler/GHC/Runtime/Loader.hs
@@ -357,7 +357,7 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
case mb_iface of
Just iface -> do
-- Try and find the required name in the exports
- let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
+ let decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod_name
, is_qual = False, is_dloc = noSrcSpan }
imp_spec = ImpSpec decl_spec ImpAll
env = mkGlobalRdrEnv
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 5d452803eb7a..4de575bbfd0f 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1095,8 +1095,14 @@ instance Diagnostic TcRnMessage where
, pprWarningTxtForMsg pragma_warning_msg ]
where
impMsg = text "imported from" <+> ppr pragma_warning_import_mod <> extra
- extra | pragma_warning_import_mod == pragma_warning_defined_mod = empty
+ extra | maybe True (pragma_warning_import_mod ==) pragma_warning_defined_mod = empty
| otherwise = text ", but defined in" <+> ppr pragma_warning_defined_mod
+ 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)]
+ TcRnIncompleteExportWarnings name locs
+ -> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "will not have its export warned about",
+ text "missing export warning at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)]
TcRnIllegalHsigDefaultMethods name meths
-> mkSimpleDecorated $
text "Illegal default method" <> plural (NE.toList meths) <+> text "in class definition of" <+> ppr name <+> text "in hsig file"
@@ -2180,6 +2186,10 @@ instance Diagnostic TcRnMessage where
-> WarningWithoutFlag
TcRnPragmaWarning{pragma_warning_msg}
-> WarningWithCategory (warningTxtCategory pragma_warning_msg)
+ TcRnDifferentExportWarnings _ _
+ -> ErrorWithoutFlag
+ TcRnIncompleteExportWarnings _ _
+ -> WarningWithFlag Opt_WarnIncompleteExportWarnings
TcRnIllegalHsigDefaultMethods{}
-> ErrorWithoutFlag
TcRnHsigFixityMismatch{}
@@ -2818,6 +2828,10 @@ instance Diagnostic TcRnMessage where
-> [SuggestSpecialiseVisibilityHints name]
TcRnPragmaWarning{}
-> noHints
+ TcRnDifferentExportWarnings _ _
+ -> noHints
+ TcRnIncompleteExportWarnings _ _
+ -> noHints
TcRnIllegalHsigDefaultMethods{}
-> noHints
TcRnIllegalQuasiQuotes{}
@@ -3074,13 +3088,13 @@ instance Diagnostic TcRnMessage where
TcRnRedundantSourceImport{}
-> noHints
TcRnImportLookup (ImportLookupBad k _ is ie patsyns_enabled) ->
- let mod = is_mod is
+ let mod_name = moduleName $ is_mod is
occ = rdrNameOcc $ ieName ie
in case k of
- BadImportAvailVar -> [ImportSuggestion occ $ CouldRemoveTypeKeyword mod]
+ BadImportAvailVar -> [ImportSuggestion occ $ CouldRemoveTypeKeyword mod_name]
BadImportNotExported -> noHints
- BadImportAvailTyCon -> [ImportSuggestion occ $ CouldAddTypeKeyword (is_mod is)]
- BadImportAvailDataCon par -> [ImportSuggestion occ $ ImportDataCon (Just (is_mod is, patsyns_enabled)) par]
+ BadImportAvailTyCon -> [ImportSuggestion occ $ CouldAddTypeKeyword mod_name]
+ BadImportAvailDataCon par -> [ImportSuggestion occ $ ImportDataCon (Just (mod_name, patsyns_enabled)) par]
BadImportNotExportedSubordinates{} -> noHints
TcRnImportLookup{}
-> noHints
@@ -3272,7 +3286,7 @@ dodgy_msg kind tc ie
, text "but it is not a type constructor or a class" ]
dodgy_msg_insert :: GlobalRdrElt -> IE GhcRn
-dodgy_msg_insert tc_gre = IEThingAll noAnn ii
+dodgy_msg_insert tc_gre = IEThingAll (Nothing, noAnn) ii
where
ii = noLocA (IEName noExtField $ noLocA $ greName tc_gre)
@@ -5322,7 +5336,7 @@ pprImportLookup = \case
let
pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc
pprImpDeclSpec iface decl_spec =
- quotes (ppr (is_mod decl_spec)) <+> case mi_boot iface of
+ quotes (ppr (moduleName $ is_mod decl_spec)) <+> case mi_boot iface of
IsBoot -> text "(hi-boot interface)"
NotBoot -> empty
withContext msgs =
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index cd94a3fed4b0..f3dc1d10f3d5 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -2528,9 +2528,31 @@ data TcRnMessage where
pragma_warning_occ :: OccName,
pragma_warning_msg :: WarningTxt GhcRn,
pragma_warning_import_mod :: ModuleName,
- pragma_warning_defined_mod :: ModuleName
+ pragma_warning_defined_mod :: Maybe ModuleName
} -> TcRnMessage
+ {-| TcRnDifferentExportWarnings is an error that occurs when the
+ warning messages for exports of a name differ between several export items.
+
+ Test case:
+ DifferentExportWarnings
+ -}
+ TcRnDifferentExportWarnings :: !Name -- ^ The name with different export warnings
+ -> NE.NonEmpty SrcSpan -- ^ The locations of export list items that differ
+ -- from the one at which the error is reported
+ -> TcRnMessage
+
+ {-| TcRnIncompleteExportWarnings is a warning (controlled by -Wincomplete-export-warnings) that
+ occurs when some of the exports of a name do not have an export warning and some do
+
+ Test case:
+ ExportWarnings6
+ -}
+ TcRnIncompleteExportWarnings :: !Name -- ^ The name that is exported
+ -> NE.NonEmpty SrcSpan -- ^ The locations of export list items that are
+ -- missing the export warning
+ -> TcRnMessage
+
{-| TcRnIllegalHsigDefaultMethods is an error that occurs when a binding for
a class default method is provided in a Backpack signature file.
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index 640104256e73..8ace4e0aa7bb 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TupleSections #-}
module GHC.Tc.Gen.Export (rnExports, exports_from_avail, classifyGREs) where
@@ -15,12 +16,14 @@ import GHC.Tc.Utils.Env
( TyThing(AConLike, AnId), tcLookupGlobal, tcLookupTyCon )
import GHC.Tc.Utils.TcType
import GHC.Rename.Doc
+import GHC.Rename.Module
import GHC.Rename.Names
import GHC.Rename.Env
import GHC.Rename.Unbound ( reportUnboundName )
import GHC.Utils.Error
import GHC.Unit.Module
import GHC.Unit.Module.Imported
+import GHC.Unit.Module.Warnings
import GHC.Core.TyCon
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -33,7 +36,7 @@ import GHC.Driver.DynFlags
import GHC.Parser.PostProcess ( setRdrNameSpace )
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Types.Unique.Set
+import GHC.Types.Unique.Map
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Name
import GHC.Types.Name.Env
@@ -48,6 +51,7 @@ import Control.Arrow ( first )
import Control.Monad ( when )
import qualified Data.List.NonEmpty as NE
import Data.Traversable ( for )
+import Data.List ( sortBy )
{-
************************************************************************
@@ -133,22 +137,34 @@ into @[C{C, T;}, T{T, D;}]@ (which satisfies the AvailTC invariant).
data ExportAccum -- The type of the accumulating parameter of
-- the main worker function in rnExports
- = ExportAccum
- ExportOccMap -- Tracks exported occurrence names
- (UniqSet ModuleName) -- Tracks (re-)exported module names
+ = ExportAccum {
+ expacc_exp_occs :: ExportOccMap,
+ -- ^ Tracks exported occurrence names
+ expacc_mods :: UniqMap ModuleName [Name],
+ -- ^ Tracks (re-)exported module names
+ -- and the names they re-export
+ expacc_warn_spans :: ExportWarnSpanNames,
+ -- ^ Information about warnings for names
+ expacc_dont_warn :: DontWarnExportNames
+ -- ^ What names not to export warnings for
+ -- (because they are exported without a warning)
+ }
+
emptyExportAccum :: ExportAccum
-emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet
+emptyExportAccum = ExportAccum emptyOccEnv emptyUniqMap [] emptyNameEnv
-accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y)))
+accumExports :: (ExportAccum -> x -> TcRn (ExportAccum, Maybe y))
-> [x]
- -> TcRn [y]
-accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum
- where f' acc x = do
- m <- attemptM (f acc x)
- pure $ case m of
- Just (Just (acc', y)) -> (acc', Just y)
- _ -> (acc, Nothing)
+ -> TcRn ([y], ExportWarnSpanNames, DontWarnExportNames)
+accumExports f xs = do
+ (ExportAccum _ _ export_warn_spans dont_warn_export, ys)
+ <- mapAccumLM f' emptyExportAccum xs
+ return ( catMaybes ys
+ , export_warn_spans
+ , dont_warn_export )
+ where f' acc x
+ = fromMaybe (acc, Nothing) <$> attemptM (f acc x)
type ExportOccMap = OccEnv (Name, IE GhcPs)
-- Tracks what a particular exported OccName
@@ -173,6 +189,7 @@ rnExports explicit_mod exports
TcGblEnv { tcg_mod = this_mod
, tcg_rdr_env = rdr_env
, tcg_imports = imports
+ , tcg_warns = warns
, tcg_src = hsc_src } = tcg_env
default_main | mainModIs (hsc_HUE hsc_env) == this_mod
, Just main_fun <- mainFunIs dflags
@@ -188,7 +205,7 @@ rnExports explicit_mod exports
; let real_exports
| explicit_mod = exports
| has_main
- = Just (noLocA [noLocA (IEVar noExtField
+ = Just (noLocA [noLocA (IEVar Nothing
(noLocA (IEName noExtField $ noLocA default_main)))])
-- ToDo: the 'noLoc' here is unhelpful if 'main'
-- turns out to be out of scope
@@ -196,7 +213,7 @@ rnExports explicit_mod exports
-- Rename the export list
; let do_it = exports_from_avail real_exports rdr_env imports this_mod
- ; (rn_exports, final_avails)
+ ; (rn_exports, final_avails, new_export_warns)
<- if hsc_src == HsigFile
then do (mb_r, msgs) <- tryTc do_it
case mb_r of
@@ -214,7 +231,17 @@ rnExports explicit_mod exports
Nothing -> Nothing
Just _ -> rn_exports
, tcg_dus = tcg_dus tcg_env `plusDU`
- usesOnly final_ns }) }
+ usesOnly final_ns
+ , tcg_warns = insertWarnExports
+ warns new_export_warns}) }
+
+-- | List of names and the information about their warnings
+-- (warning, export list item span)
+type ExportWarnSpanNames = [(Name, WarningTxt GhcRn, SrcSpan)]
+
+-- | Map from names that should not have export warnings to
+-- the spans of export list items that are missing those warnings
+type DontWarnExportNames = NameEnv (NE.NonEmpty SrcSpan)
exports_from_avail :: Maybe (LocatedL [LIE GhcPs])
-- ^ 'Nothing' means no explicit export list
@@ -224,8 +251,8 @@ exports_from_avail :: Maybe (LocatedL [LIE GhcPs])
-- @module Foo@ export is valid (it's not valid
-- if we didn't import @Foo@!)
-> Module
- -> RnM (Maybe [(LIE GhcRn, Avails)], Avails)
- -- (Nothing, _) <=> no explicit export list
+ -> RnM (Maybe [(LIE GhcRn, Avails)], Avails, ExportWarnNames GhcRn)
+ -- (Nothing, _, _) <=> no explicit export list
-- if explicit export list is present it contains
-- each renamed export item together with its exported
-- names.
@@ -240,7 +267,7 @@ exports_from_avail Nothing rdr_env _imports _this_mod
; let avails =
map fix_faminst . gresToAvailInfo
. filter isLocalGRE . globalRdrEnvElts $ rdr_env
- ; return (Nothing, avails) }
+ ; return (Nothing, avails, []) }
where
-- #11164: when we define a data instance
-- but not data family, re-export the family
@@ -256,12 +283,14 @@ exports_from_avail Nothing rdr_env _imports _this_mod
exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
- = do ie_avails <- accumExports do_litem rdr_items
+ = do (ie_avails, export_warn_spans, dont_warn_export)
+ <- accumExports do_litem rdr_items
let final_exports = nubAvails (concatMap snd ie_avails) -- Combine families
- return (Just ie_avails, final_exports)
+ export_warn_names <- aggregate_warnings export_warn_spans dont_warn_export
+ return (Just ie_avails, final_exports, export_warn_names)
where
do_litem :: ExportAccum -> LIE GhcPs
- -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
+ -> RnM (ExportAccum, Maybe (LIE GhcRn, Avails))
do_litem acc lie = setSrcSpan (getLocA lie) (exports_from_item acc lie)
-- Maps a parent to its in-scope children
@@ -282,30 +311,45 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
, imv <- importedByUser xs ]
exports_from_item :: ExportAccum -> LIE GhcPs
- -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
- exports_from_item (ExportAccum occs earlier_mods)
- (L loc ie@(IEModuleContents _ lmod@(L _ mod)))
- | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M
+ -> RnM (ExportAccum, Maybe (LIE GhcRn, Avails))
+ exports_from_item expacc@ExportAccum{
+ expacc_exp_occs = occs,
+ expacc_mods = earlier_mods,
+ expacc_warn_spans = export_warn_spans,
+ expacc_dont_warn = dont_warn_export
+ } (L loc ie@(IEModuleContents (warn_txt_ps, _) lmod@(L _ mod)))
+ | Just exported_names <- lookupUniqMap earlier_mods mod -- Duplicate export of M
= do { addDiagnostic (TcRnDupeModuleExport mod)
- ; return Nothing}
+ ; (export_warn_spans', dont_warn_export', _) <-
+ process_warning export_warn_spans
+ dont_warn_export
+ exported_names
+ warn_txt_ps
+ (locA loc)
+ -- Checks if all the names are exported with the same warning message
+ -- or if they should not be warned about
+ ; return ( expacc{ expacc_warn_spans = export_warn_spans'
+ , expacc_dont_warn = dont_warn_export' }
+ , Nothing ) }
| otherwise
- = do { let { exportValid = (mod `elem` imported_modules)
- || (moduleName this_mod == mod)
- ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env)
- ; new_gres = [ gre'
- | (gre, _) <- gre_prs
- , gre' <- expand_tyty_gre gre ]
- ; new_exports = map availFromGRE new_gres
- ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
- ; mods = addOneToUniqSet earlier_mods mod
+ = do { let { exportValid = (mod `elem` imported_modules)
+ || (moduleName this_mod == mod)
+ ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env)
+ ; new_gres = [ gre'
+ | (gre, _) <- gre_prs
+ , gre' <- expand_tyty_gre gre ]
+ ; new_exports = map availFromGRE new_gres
+ ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
+ ; exported_names = map greName new_gres
+ ; mods = addToUniqMap earlier_mods mod exported_names
}
; checkErr exportValid (TcRnExportedModNotImported mod)
; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod)
; traceRn "efa" (ppr mod $$ ppr all_gres)
- ; addUsedGREs all_gres
+ ; addUsedGREs ExportDeprecationWarnings all_gres
; occs' <- check_occs occs ie new_gres
-- This check_occs not only finds conflicts
@@ -314,54 +358,114 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
-- 'M.x' is in scope in several ways, we'll have
-- several members of mod_avails with the same
-- OccName.
+ ; (export_warn_spans', dont_warn_export', warn_txt_rn) <-
+ process_warning export_warn_spans
+ dont_warn_export
+ exported_names
+ warn_txt_ps
+ (locA loc)
+
; traceRn "export_mod"
(vcat [ ppr mod
, ppr new_exports ])
- ; return $ Just $
- ( ExportAccum occs' mods
- , ( L loc (IEModuleContents noExtField lmod)
- , new_exports) ) }
-
- exports_from_item acc@(ExportAccum occs mods) (L loc ie) = do
- m_new_ie <- lookup_doc_ie ie
- case m_new_ie of
- Just new_ie -> return $ Just (acc, (L loc new_ie, []))
+ ; return ( ExportAccum { expacc_exp_occs = occs'
+ , expacc_mods = mods
+ , expacc_warn_spans = export_warn_spans'
+ , expacc_dont_warn = dont_warn_export' }
+ , Just (L loc (IEModuleContents warn_txt_rn lmod), new_exports) ) }
+
+ exports_from_item acc lie = do
+ m_doc_ie <- lookup_doc_ie lie
+ case m_doc_ie of
+ Just new_ie -> return (acc, Just (new_ie, []))
Nothing -> do
- let finish (occs', new_ie, avail) = (ExportAccum occs' mods, (L loc new_ie, [avail]))
- fmap finish <$> lookup_ie occs ie
+ m_ie <- lookup_ie acc lie
+ case m_ie of
+ Nothing -> return (acc, Nothing)
+ Just (acc', new_ie, avail)
+ -> return (acc', Just (new_ie, [avail]))
-------------
- lookup_ie :: ExportOccMap -> IE GhcPs -> RnM (Maybe (ExportOccMap, IE GhcRn, AvailInfo))
- lookup_ie occs ie@(IEVar ann l)
+ lookup_ie :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, LIE GhcRn, AvailInfo))
+ lookup_ie expacc@ExportAccum{
+ expacc_exp_occs = occs,
+ expacc_warn_spans = export_warn_spans,
+ expacc_dont_warn = dont_warn_export
+ } (L loc ie@(IEVar warn_txt_ps l))
= do mb_gre <- lookupGreAvailRn $ lieWrappedName l
for mb_gre $ \ gre -> do
let avail = availFromGRE gre
name = greName gre
- occs' <- check_occs occs ie [gre]
- return (occs', IEVar ann (replaceLWrappedName l name), avail)
- lookup_ie occs ie@(IEThingAbs ann l)
+ occs' <- check_occs occs ie [gre]
+ (export_warn_spans', dont_warn_export', warn_txt_rn)
+ <- process_warning export_warn_spans
+ dont_warn_export
+ [name]
+ warn_txt_ps
+ (locA loc)
+
+ return ( expacc{ expacc_exp_occs = occs'
+ , expacc_warn_spans = export_warn_spans'
+ , expacc_dont_warn = dont_warn_export' }
+ , L loc (IEVar warn_txt_rn (replaceLWrappedName l name))
+ , avail )
+
+ lookup_ie expacc@ExportAccum{
+ expacc_exp_occs = occs,
+ expacc_warn_spans = export_warn_spans,
+ expacc_dont_warn = dont_warn_export
+ } (L loc ie@(IEThingAbs (warn_txt_ps, ann) l))
= do mb_gre <- lookupGreAvailRn $ lieWrappedName l
for mb_gre $ \ gre -> do
let avail = availFromGRE gre
name = greName gre
- occs' <- check_occs occs ie [gre]
- return ( occs'
- , IEThingAbs ann (replaceLWrappedName l name)
- , avail)
- lookup_ie occs ie@(IEThingAll ann l)
+ occs' <- check_occs occs ie [gre]
+ (export_warn_spans', dont_warn_export', warn_txt_rn)
+ <- process_warning export_warn_spans
+ dont_warn_export
+ [name]
+ warn_txt_ps
+ (locA loc)
+
+ return ( expacc{ expacc_exp_occs = occs'
+ , expacc_warn_spans = export_warn_spans'
+ , expacc_dont_warn = dont_warn_export' }
+ , L loc (IEThingAbs (warn_txt_rn, ann) (replaceLWrappedName l name))
+ , avail )
+
+ lookup_ie expacc@ExportAccum{
+ expacc_exp_occs = occs,
+ expacc_warn_spans = export_warn_spans,
+ expacc_dont_warn = dont_warn_export
+ } (L loc ie@(IEThingAll (warn_txt_ps, ann) l))
= do mb_gre <- lookupGreAvailRn $ lieWrappedName l
for mb_gre $ \ par -> do
all_kids <- lookup_ie_kids_all ie l par
let name = greName par
- kids_avails = map greName all_kids
- occs' <- check_occs occs ie (par:all_kids)
- return ( occs'
- , IEThingAll ann (replaceLWrappedName l name)
- , AvailTC name (name:kids_avails))
-
- lookup_ie occs ie@(IEThingWith ann l wc sub_rdrs)
+ all_gres = par : all_kids
+ all_names = map greName all_gres
+
+ occs' <- check_occs occs ie all_gres
+ (export_warn_spans', dont_warn_export', warn_txt_rn)
+ <- process_warning export_warn_spans
+ dont_warn_export
+ all_names
+ warn_txt_ps
+ (locA loc)
+
+ return ( expacc{ expacc_exp_occs = occs'
+ , expacc_warn_spans = export_warn_spans'
+ , expacc_dont_warn = dont_warn_export' }
+ , L loc (IEThingAll (warn_txt_rn, ann) (replaceLWrappedName l name))
+ , AvailTC name all_names )
+
+ lookup_ie expacc@ExportAccum{
+ expacc_exp_occs = occs,
+ expacc_warn_spans = export_warn_spans,
+ expacc_dont_warn = dont_warn_export
+ } (L loc ie@(IEThingWith (warn_txt_ps, ann) l wc sub_rdrs))
= do mb_gre <- addExportErrCtxt ie
$ lookupGreAvailRn $ lieWrappedName l
for mb_gre $ \ par -> do
@@ -376,11 +480,22 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
let name = greName par
all_kids = with_kids ++ wc_kids
- kids_avails = map greName all_kids
- occs' <- check_occs occs ie (par:all_kids)
- return ( occs'
- , IEThingWith ann (replaceLWrappedName l name) wc subs
- , AvailTC name (name:kids_avails))
+ all_gres = par : all_kids
+ all_names = map greName all_gres
+
+ occs' <- check_occs occs ie all_gres
+ (export_warn_spans', dont_warn_export', warn_txt_rn)
+ <- process_warning export_warn_spans
+ dont_warn_export
+ all_names
+ warn_txt_ps
+ (locA loc)
+
+ return ( expacc{ expacc_exp_occs = occs'
+ , expacc_warn_spans = export_warn_spans'
+ , expacc_dont_warn = dont_warn_export' }
+ , L loc (IEThingWith (warn_txt_rn, ann) (replaceLWrappedName l name) wc subs)
+ , AvailTC name all_names )
lookup_ie _ _ = panic "lookup_ie" -- Other cases covered earlier
@@ -407,21 +522,102 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
; return gres }
-------------
- lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn))
- lookup_doc_ie (IEGroup _ lev doc) = do
+
+ 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
+ -- of the export statements have a warning)
+ -- - If the Name already has a warning, adds it
+ 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
+ -> 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
+ process_warning export_warn_spans
+ dont_warn_export
+ names Nothing loc
+ = return ( export_warn_spans
+ , foldr update_dont_warn_export
+ dont_warn_export names
+ , Nothing )
+ where
+ update_dont_warn_export :: Name -> DontWarnExportNames -> DontWarnExportNames
+ update_dont_warn_export name dont_warn_export'
+ = extendNameEnv_Acc (NE.<|)
+ NE.singleton
+ dont_warn_export'
+ name
+ loc
+
+ process_warning export_warn_spans
+ dont_warn_export
+ names (Just warn_txt_ps) loc
+ = do
+ warn_txt_rn <- rn_warning_txt_loc 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
+ , Just warn_txt_rn )
+
+ -- For each name exported with any warnings throws an error
+ -- if there are any exports of that name with a different warning
+ aggregate_warnings :: ExportWarnSpanNames
+ -> DontWarnExportNames
+ -> RnM (ExportWarnNames GhcRn)
+ aggregate_warnings export_warn_spans dont_warn_export
+ = fmap catMaybes
+ $ mapM (aggregate_single . extract_name)
+ $ NE.groupBy (\(n1, _, _) (n2, _, _) -> n1 == n2)
+ $ sortBy (\(n1, _, _) (n2, _, _) -> n1 `compare` n2) export_warn_spans
+ where
+ extract_name :: NE.NonEmpty (Name, WarningTxt GhcRn, SrcSpan)
+ -> (Name, NE.NonEmpty (WarningTxt GhcRn, SrcSpan))
+ extract_name l@((name, _, _) NE.:| _)
+ = (name, NE.map (\(_, warn_txt, span) -> (warn_txt, span)) l)
+
+ aggregate_single :: (Name, NE.NonEmpty (WarningTxt GhcRn, SrcSpan))
+ -> RnM (Maybe (Name, WarningTxt GhcRn))
+ aggregate_single (name, (warn_txt_rn, loc) NE.:| warn_spans)
+ = do
+ -- Emit an error if the warnings differ
+ case NE.nonEmpty spans_different of
+ Nothing -> return ()
+ Just spans_different
+ -> addErrAt loc (TcRnDifferentExportWarnings name spans_different)
+ -- Emit a warning if some export list items do not have a warning
+ case lookupNameEnv dont_warn_export name of
+ Nothing -> return $ Just (name, warn_txt_rn)
+ Just not_warned_spans -> do
+ addDiagnosticAt loc (TcRnIncompleteExportWarnings name not_warned_spans)
+ return Nothing
+ where
+ spans_different = map snd $ filter (not . warningTxtSame warn_txt_rn . fst) warn_spans
+
+ -------------
+ lookup_doc_ie :: LIE GhcPs -> RnM (Maybe (LIE GhcRn))
+ lookup_doc_ie (L loc (IEGroup _ lev doc)) = do
doc' <- rnLHsDoc doc
- pure $ Just (IEGroup noExtField lev doc')
- lookup_doc_ie (IEDoc _ doc) = do
+ pure $ Just (L loc (IEGroup noExtField lev doc'))
+ lookup_doc_ie (L loc (IEDoc _ doc)) = do
doc' <- rnLHsDoc doc
- pure $ Just (IEDoc noExtField doc')
- lookup_doc_ie (IEDocNamed _ str) = pure $ Just (IEDocNamed noExtField str)
+ pure $ Just (L loc (IEDoc noExtField doc'))
+ lookup_doc_ie (L loc (IEDocNamed _ str))
+ = pure $ Just (L loc (IEDocNamed noExtField str))
lookup_doc_ie _ = pure Nothing
-- In an export item M.T(A,B,C), we want to treat the uses of
-- A,B,C as if they were M.A, M.B, M.C
-- Happily pickGREs does just the right thing
addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()
- addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)
+ addUsedKids parent_rdr kid_gres
+ = addUsedGREs ExportDeprecationWarnings (pickGREs parent_rdr kid_gres)
-- Renaming and typechecking of exports happens after everything else has
-- been typechecked.
@@ -503,7 +699,8 @@ lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items
doOne n = do
let bareName = (ieWrappedName . unLoc) n
- lkup v = lookupSubBndrOcc_helper False DisableDeprecationWarnings -- Do not report export list deprecations
+ -- Do not report export list declaration deprecations
+ lkup v = lookupSubBndrOcc_helper False ExportDeprecationWarnings
spec_parent (setRdrNameSpace bareName v)
name <- combineChildLookupResult $ map lkup $
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 883543499f0a..2953f1281f1b 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/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(EnableDeprecationWarnings) )
+import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls, DeprecationWarnings(..) )
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Arrow
import GHC.Tc.Gen.Match
@@ -1423,7 +1423,7 @@ disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty
-- Mark the record fields as used, now that we have disambiguated.
-- There is no risk of duplicate deprecation warnings, as we have
-- not marked the GREs as used previously.
- ; setSrcSpanA loc $ mapM_ (addUsedGRE EnableDeprecationWarnings) mb_gre
+ ; setSrcSpanA loc $ mapM_ (addUsedGRE AllDeprecationWarnings) mb_gre
; sel <- tcLookupId (greName fld_gre)
; return $ L l HsFieldBind
{ hfbAnn = hfbAnn upd
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index 8fae1f31b16e..a22ff699d16c 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -23,7 +23,7 @@ import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Origin (InstanceWhat (..), SafeOverlapping)
import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )
-import GHC.Rename.Env( addUsedGRE, DeprecationWarnings(EnableDeprecationWarnings) )
+import GHC.Rename.Env( addUsedGRE, DeprecationWarnings (..) )
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
@@ -942,7 +942,7 @@ matchHasField dflags short_cut clas tys
-- it must not be higher-rank.
; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty
then do { -- See Note [Unused name reporting and HasField]
- addUsedGRE EnableDeprecationWarnings gre
+ addUsedGRE AllDeprecationWarnings gre
; keepAlive (greName gre)
; return OneInst { cir_new_theta = theta
, cir_mk_ev = mk_ev
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 724ebee1b957..64e3df216fa4 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -1691,7 +1691,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
-- See Note [Newtype constructor usage in foreign declarations]
- addUsedGREs (bagToList fo_gres) ;
+ addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ;
return (tcg_env', tcl_env)
}}}}}}
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 0c7cb0cc3598..da38736dbfc7 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -198,6 +198,7 @@ import Data.List ( mapAccumL )
import Data.Foldable
import qualified Data.Semigroup as S
import GHC.Types.SrcLoc
+import GHC.Rename.Env
#if defined(DEBUG)
import GHC.Types.Unique.Set (nonDetEltsUniqSet)
@@ -1372,7 +1373,7 @@ tcLookupTyCon n = wrapTcS $ TcM.tcLookupTyCon n
-- might), so it's not worth losing sleep over.
recordUsedGREs :: Bag GlobalRdrElt -> TcS ()
recordUsedGREs gres
- = do { wrapTcS $ TcM.addUsedGREs gre_list
+ = do { wrapTcS $ TcM.addUsedGREs NoDeprecationWarnings gre_list
-- If a newtype constructor was imported, don't warn about not
-- importing it...
; wrapTcS $ traverse_ (TcM.keepAlive . greName) gre_list }
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index b82678e4ee3f..b1b69868fe80 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -636,7 +636,7 @@ mergeSignatures
-- because we need module
-- LocalSig (from the local
-- export list) to match it!
- is_mod = mod_name,
+ is_mod = mi_module ireq_iface,
is_as = mod_name,
is_qual = False,
is_dloc = locA loc
@@ -649,7 +649,7 @@ mergeSignatures
emptyImportAvails
(tcg_semantic_mod tcg_env)
case mb_r of
- Just (_, as2) -> return (thinModIface as2 ireq_iface, as2)
+ Just (_, as2, _) -> return (thinModIface as2 ireq_iface, as2)
Nothing -> addMessages msgs >> failM
-- We can't thin signatures from non-signature packages
_ -> return (ireq_iface, as1)
@@ -676,7 +676,7 @@ mergeSignatures
exports = nameShapeExports nsubst
rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env Nothing exports)
_warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports)
- warns = NoWarnings
+ warns = emptyWarn
{-
-- TODO: Warnings are transitive, but this is not what we want here:
-- if a module reexports an entity from a signature, that should be OK.
@@ -706,7 +706,7 @@ mergeSignatures
-- Make sure we didn't refer to anything that doesn't actually exist
-- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return ()
- (mb_lies, _) <- exports_from_avail mb_exports rdr_env
+ (mb_lies, _, _) <- exports_from_avail mb_exports rdr_env
(tcg_imports tcg_env) (tcg_semantic_mod tcg_env)
{- -- NB: This is commented out, because warns above is disabled.
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index be9049a20923..2dd212b95742 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -68,7 +68,7 @@ module GHC.Tc.Utils.Monad(
addErr,
failWith, failAt,
addErrAt, addErrs,
- checkErr,
+ checkErr, checkErrAt,
addMessages,
discardWarnings, mkDetailedMessage,
@@ -338,7 +338,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
tcg_sigs = emptyNameSet,
tcg_ksigs = emptyNameSet,
tcg_ev_binds = emptyBag,
- tcg_warns = NoWarnings,
+ tcg_warns = emptyWarn,
tcg_anns = [],
tcg_tcs = [],
tcg_insts = [],
@@ -1084,6 +1084,9 @@ checkErr :: Bool -> TcRnMessage -> TcRn ()
-- Add the error if the bool is False
checkErr ok msg = unless ok (addErr msg)
+checkErrAt :: SrcSpan -> Bool -> TcRnMessage -> TcRn ()
+checkErrAt loc ok msg = unless ok (addErrAt loc msg)
+
addMessages :: Messages TcRnMessage -> TcRn ()
addMessages msgs1
= do { errs_var <- getErrsVar
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 794e0862aec1..0a9c053eb3e7 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -472,6 +472,8 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnUnexpectedPragmas" = 88293
GhcDiagnosticCode "TcRnNonOverloadedSpecialisePragma" = 35827
GhcDiagnosticCode "TcRnSpecialiseNotVisible" = 85337
+ GhcDiagnosticCode "TcRnDifferentExportWarnings" = 92878
+ GhcDiagnosticCode "TcRnIncompleteExportWarnings" = 94721
GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl" = 50649
GhcDiagnosticCode "TcRnBindVarAlreadyInScope" = 69710
GhcDiagnosticCode "TcRnBindMultipleVariables" = 92957
diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs
index 49913fd2fa73..39a4e12e6992 100644
--- a/compiler/GHC/Types/Hint/Ppr.hs
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -362,7 +362,7 @@ pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope)
RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l))
ImportedBy is ->
pp_ns rdr_name <+> quotes (ppr rdr_name) <+>
- parens (text "imported from" <+> ppr (is_mod is))
+ parens (text "imported from" <+> ppr (moduleName $ is_mod is))
where
pp_ns :: RdrName -> SDoc
diff --git a/compiler/GHC/Types/Name/Env.hs b/compiler/GHC/Types/Name/Env.hs
index f96d3957fb6b..7aa3f302d86c 100644
--- a/compiler/GHC/Types/Name/Env.hs
+++ b/compiler/GHC/Types/Name/Env.hs
@@ -15,6 +15,7 @@ module GHC.Types.Name.Env (
-- ** Manipulating these environments
mkNameEnv, mkNameEnvWith,
+ fromUniqMap,
emptyNameEnv, isEmptyNameEnv,
unitNameEnv, nonDetNameEnvElts,
extendNameEnv_C, extendNameEnv_Acc, extendNameEnv,
@@ -23,6 +24,7 @@ module GHC.Types.Name.Env (
mapMaybeNameEnv,
extendNameEnvListWith,
plusNameEnv, plusNameEnv_C, plusNameEnv_CD, plusNameEnv_CD2, alterNameEnv,
+ plusNameEnvList, plusNameEnvListWith,
lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,
elemNameEnv, mapNameEnv, disjointNameEnv,
seqEltsNameEnv,
@@ -49,6 +51,7 @@ import GHC.Data.Graph.Directed
import GHC.Types.Name
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
+import GHC.Types.Unique.Map
import GHC.Data.Maybe
{-
@@ -105,6 +108,7 @@ emptyNameEnv :: NameEnv a
isEmptyNameEnv :: NameEnv a -> Bool
mkNameEnv :: [(Name,a)] -> NameEnv a
mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a
+fromUniqMap :: UniqMap Name a -> NameEnv a
nonDetNameEnvElts :: NameEnv a -> [a]
alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a
extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
@@ -114,6 +118,8 @@ plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_CD :: (a->a->a) -> NameEnv a -> a -> NameEnv a -> a -> NameEnv a
plusNameEnv_CD2 :: (Maybe a->Maybe a->a) -> NameEnv a -> NameEnv a -> NameEnv a
+plusNameEnvList :: [NameEnv a] -> NameEnv a
+plusNameEnvListWith :: (a->a->a) -> [NameEnv a] -> NameEnv a
extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a
extendNameEnvListWith :: (a -> Name) -> NameEnv a -> [a] -> NameEnv a
extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a
@@ -141,12 +147,17 @@ lookupNameEnv x y = lookupUFM x y
alterNameEnv = alterUFM
mkNameEnv l = listToUFM l
mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a))
+fromUniqMap = mapUFM snd . getUniqMap
elemNameEnv x y = elemUFM x y
plusNameEnv x y = plusUFM x y
plusNameEnv_C f x y = plusUFM_C f x y
{-# INLINE plusNameEnv_CD #-}
plusNameEnv_CD f x d y b = plusUFM_CD f x d y b
plusNameEnv_CD2 f x y = plusUFM_CD2 f x y
+{-# INLINE plusNameEnvList #-}
+plusNameEnvList xs = plusUFMList xs
+{-# INLINE plusNameEnvListWith #-}
+plusNameEnvListWith f xs = plusUFMListWith f xs
extendNameEnv_C f x y z = addToUFM_C f x y z
mapNameEnv f x = mapUFM f x
extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b
diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs
index 17be091c74d2..c77dd6ba53e9 100644
--- a/compiler/GHC/Types/Name/Reader.hs
+++ b/compiler/GHC/Types/Name/Reader.hs
@@ -1503,7 +1503,7 @@ shadowNames drop_only_qualified env new_gres = minusOccEnv_C_Ns do_shadowing env
= ImpSpec id_spec ImpAll
where
old_mod_name = moduleName old_mod
- id_spec = ImpDeclSpec { is_mod = old_mod_name
+ id_spec = ImpDeclSpec { is_mod = old_mod
, is_as = old_mod_name
, is_qual = True
, is_dloc = greDefinitionSrcSpan old_gre }
@@ -1653,7 +1653,7 @@ data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec,
-- shared among all the 'Provenance's for that decl
data ImpDeclSpec
= ImpDeclSpec {
- is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@
+ is_mod :: Module, -- ^ Module imported, e.g. @import Muggle@
-- Note the @Muggle@ may well not be
-- the defining module for this thing!
@@ -1774,7 +1774,7 @@ importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl
importSpecLoc (ImpSpec _ item) = is_iloc item
importSpecModule :: ImportSpec -> ModuleName
-importSpecModule is = is_mod (is_decl is)
+importSpecModule = moduleName . is_mod . is_decl
isExplicitItem :: ImpItemSpec -> Bool
isExplicitItem ImpAll = False
diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs
index 8bdba40bbabb..0a6b220be6c3 100644
--- a/compiler/GHC/Unit/Module/ModIface.hs
+++ b/compiler/GHC/Unit/Module/ModIface.hs
@@ -110,8 +110,10 @@ data ModIfaceBackend = ModIfaceBackend
-- other fields and are not put into the interface file.
-- Not really produced by the backend but there is no need to create them
-- any earlier.
- , mi_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn))
- -- ^ Cached lookup for 'mi_warns'
+ , mi_decl_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn))
+ -- ^ Cached lookup for 'mi_warns' for declaration deprecations
+ , mi_export_warn_fn :: !(Name -> Maybe (WarningTxt GhcRn))
+ -- ^ Cached lookup for 'mi_warns' for export deprecations
, mi_fix_fn :: !(OccName -> Maybe Fixity)
-- ^ Cached lookup for 'mi_fixities'
, mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint))
@@ -479,7 +481,8 @@ instance Binary ModIface where
mi_finsts = hasFamInsts,
mi_exp_hash = exp_hash,
mi_orphan_hash = orphan_hash,
- mi_warn_fn = mkIfaceWarnCache $ fromIfaceWarnings warns,
+ mi_decl_warn_fn = mkIfaceDeclWarnCache $ fromIfaceWarnings warns,
+ mi_export_warn_fn = mkIfaceExportWarnCache $ fromIfaceWarnings warns,
mi_fix_fn = mkIfaceFixCache fixities,
mi_hash_fn = mkIfaceHashCache decls
}})
@@ -498,7 +501,7 @@ emptyPartialModIface mod
mi_exports = [],
mi_used_th = False,
mi_fixities = [],
- mi_warns = IfNoWarnings,
+ mi_warns = IfWarnSome [] [],
mi_anns = [],
mi_insts = [],
mi_fam_insts = [],
@@ -530,7 +533,8 @@ emptyFullModIface mod =
mi_finsts = False,
mi_exp_hash = fingerprint0,
mi_orphan_hash = fingerprint0,
- mi_warn_fn = emptyIfaceWarnCache,
+ mi_decl_warn_fn = emptyIfaceWarnCache,
+ mi_export_warn_fn = emptyIfaceWarnCache,
mi_fix_fn = emptyIfaceFixCache,
mi_hash_fn = emptyIfaceHashCache } }
@@ -592,7 +596,8 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
instance NFData (ModIfaceBackend) where
rnf (ModIfaceBackend{ mi_iface_hash, mi_mod_hash, mi_flag_hash, mi_opt_hash
, mi_hpc_hash, mi_plugin_hash, mi_orphan, mi_finsts, mi_exp_hash
- , mi_orphan_hash, mi_warn_fn, mi_fix_fn, mi_hash_fn})
+ , mi_orphan_hash, mi_decl_warn_fn, mi_export_warn_fn, mi_fix_fn
+ , mi_hash_fn})
= rnf mi_iface_hash
`seq` rnf mi_mod_hash
`seq` rnf mi_flag_hash
@@ -603,7 +608,8 @@ instance NFData (ModIfaceBackend) where
`seq` rnf mi_finsts
`seq` rnf mi_exp_hash
`seq` rnf mi_orphan_hash
- `seq` rnf mi_warn_fn
+ `seq` rnf mi_decl_warn_fn
+ `seq` rnf mi_export_warn_fn
`seq` rnf mi_fix_fn
`seq` rnf mi_hash_fn
diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs
index ee49baf55412..ed122e103730 100644
--- a/compiler/GHC/Unit/Module/Warnings.hs
+++ b/compiler/GHC/Unit/Module/Warnings.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
-- | Warnings for a module
@@ -24,11 +25,18 @@ module GHC.Unit.Module.Warnings
, Warnings (..)
, WarningTxt (..)
+ , DeclWarnOccNames
+ , ExportWarnNames
, warningTxtCategory
+ , warningTxtMessage
+ , warningTxtSame
, pprWarningTxtForMsg
- , mkIfaceWarnCache
+ , emptyWarn
+ , mkIfaceDeclWarnCache
+ , mkIfaceExportWarnCache
, emptyIfaceWarnCache
- , plusWarns
+ , insertWarnDecls
+ , insertWarnExports
)
where
@@ -37,6 +45,8 @@ import GHC.Prelude
import GHC.Data.FastString (FastString, mkFastString, unpackFS)
import GHC.Types.SourceText
import GHC.Types.Name.Occurrence
+import GHC.Types.Name.Env
+import GHC.Types.Name (Name)
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Set
@@ -190,6 +200,24 @@ warningTxtCategory :: WarningTxt pass -> WarningCategory
warningTxtCategory (WarningTxt (Just (L _ cat)) _ _) = cat
warningTxtCategory _ = defaultWarningCategory
+-- | The message that the WarningTxt was specified to output
+warningTxtMessage :: WarningTxt p -> [Located (WithHsDocIdentifiers StringLiteral p)]
+warningTxtMessage (WarningTxt _ _ m) = m
+warningTxtMessage (DeprecatedTxt _ m) = m
+
+-- | True if the 2 WarningTxts have the same category and messages
+warningTxtSame :: WarningTxt p1 -> WarningTxt p2 -> Bool
+warningTxtSame w1 w2
+ = warningTxtCategory w1 == warningTxtCategory w2
+ && literal_message w1 == literal_message w2
+ && same_type
+ where
+ literal_message :: WarningTxt p -> [StringLiteral]
+ literal_message = map (hsDocString . unLoc) . warningTxtMessage
+ same_type | DeprecatedTxt {} <- w1, DeprecatedTxt {} <- w2 = True
+ | WarningTxt {} <- w1, WarningTxt {} <- w2 = True
+ | otherwise = False
+
deriving instance Eq (IdP pass) => Eq (WarningTxt pass)
deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass)
@@ -220,13 +248,13 @@ pprWarningTxtForMsg (DeprecatedTxt _ ds)
doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ds))
--- | Warning information for a module
+-- | Warning information from a module
data Warnings pass
- = NoWarnings -- ^ Nothing deprecated
- | WarnAll (WarningTxt pass) -- ^ Whole module deprecated
- | WarnSome [(OccName,WarningTxt pass)] -- ^ Some specific things deprecated
+ = WarnSome (DeclWarnOccNames pass) -- ^ Names deprecated (may be empty)
+ (ExportWarnNames pass) -- ^ Exports deprecated (may be empty)
+ | WarnAll (WarningTxt pass) -- ^ Whole module deprecated
- -- Only an OccName is needed because
+ -- For the module-specific names only an OccName is needed because
-- (1) a deprecation always applies to a binding
-- defined in the module in which the deprecation appears.
-- (2) deprecations are only reported outside the defining module.
@@ -246,22 +274,44 @@ data Warnings pass
--
-- this is in contrast with fixity declarations, where we need to map
-- a Name to its fixity declaration.
+ --
+ -- For export deprecations we need to know where the symbol comes from, since
+ -- we need to be able to check if the deprecated export that was imported is
+ -- the same thing as imported by another import, which would not trigger
+ -- a deprecation message.
+
+-- | Deprecated declarations
+type DeclWarnOccNames pass = [(OccName, WarningTxt pass)]
+
+-- | Names that are deprecated as exports
+type ExportWarnNames pass = [(Name, WarningTxt pass)]
deriving instance Eq (IdP pass) => Eq (Warnings pass)
--- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'
-mkIfaceWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p)
-mkIfaceWarnCache NoWarnings = \_ -> Nothing
-mkIfaceWarnCache (WarnAll t) = \_ -> Just t
-mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs)
+emptyWarn :: Warnings p
+emptyWarn = WarnSome [] []
-emptyIfaceWarnCache :: OccName -> Maybe (WarningTxt p)
-emptyIfaceWarnCache _ = Nothing
+-- | Constructs the cache for the 'mi_decl_warn_fn' field of a 'ModIface'
+mkIfaceDeclWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p)
+mkIfaceDeclWarnCache (WarnAll t) = \_ -> Just t
+mkIfaceDeclWarnCache (WarnSome vs _) = lookupOccEnv (mkOccEnv vs)
-plusWarns :: Warnings p -> Warnings p -> Warnings p
-plusWarns d NoWarnings = d
-plusWarns NoWarnings d = d
-plusWarns _ (WarnAll t) = WarnAll t
-plusWarns (WarnAll t) _ = WarnAll t
-plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)
+-- | Constructs the cache for the 'mi_export_warn_fn' field of a 'ModIface'
+mkIfaceExportWarnCache :: Warnings p -> Name -> Maybe (WarningTxt p)
+mkIfaceExportWarnCache (WarnAll _) = const Nothing -- We do not want a double report of the module deprecation
+mkIfaceExportWarnCache (WarnSome _ ds) = lookupNameEnv (mkNameEnv ds)
+
+emptyIfaceWarnCache :: name -> Maybe (WarningTxt p)
+emptyIfaceWarnCache _ = Nothing
+insertWarnDecls :: Warnings p -- ^ Existing warnings
+ -> [(OccName, WarningTxt p)] -- ^ New declaration deprecations
+ -> Warnings p -- ^ Updated warnings
+insertWarnDecls ws@(WarnAll _) _ = ws
+insertWarnDecls (WarnSome wns wes) wns' = WarnSome (wns ++ wns') wes
+
+insertWarnExports :: Warnings p -- ^ Existing warnings
+ -> [(Name, WarningTxt p)] -- ^ New export deprecations
+ -> Warnings p -- ^ Updated warnings
+insertWarnExports ws@(WarnAll _) _ = ws
+insertWarnExports (WarnSome wns wes) wes' = WarnSome wns (wes ++ wes')
diff --git a/docs/users_guide/9.8.1-notes.rst b/docs/users_guide/9.8.1-notes.rst
index cd1e414d5aff..95e564109f2d 100644
--- a/docs/users_guide/9.8.1-notes.rst
+++ b/docs/users_guide/9.8.1-notes.rst
@@ -162,6 +162,23 @@ Compiler
In a test compiling GHC itself, the size of the :ghc-flag:`-finfo-table-map`
enabled build results was reduced by over 20% when compression was enabled.
+- GHC Proposal `#134
+ <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0134-deprecating-exports-proposal.rst>`_
+ has been implemented. This makes it possible to deprecate certain names exported from a module, without deprecating
+ the name itself. You can check the full specification of the feature at :ref:`warning-deprecated-pragma`.
+
+ For example ::
+
+ module X (
+ {-# WARNING "do not use that constructor" D(D1),
+ D(D2)
+ )
+ D = D1 | D2
+
+ This allows for changing the structure of a library without immediately breaking user code,
+ but instead being able to warn the user that a change in the library interface
+ will occur in the future.
+
GHCi
~~~~
@@ -223,6 +240,11 @@ Runtime system
This allows how messages are rendered and explained to users to be modified.
We use this functionality in GHCi to modify how some messages are displayed.
+- The extensions fields of constructors of ``IE`` now take ``Maybe (WarningTxt p)``
+ in ``GhcPs`` and ``GhcRn`` variants of the Syntax Tree.
+ This represents the warning assigned to a certain export item,
+ which is used for :ref:`deprecated-exports`.
+
``ghc-heap`` library
~~~~~~~~~~~~~~~~~~~~
diff --git a/docs/users_guide/exts/pragmas.rst b/docs/users_guide/exts/pragmas.rst
index 2c8c5d47591f..aff9fc253a7e 100644
--- a/docs/users_guide/exts/pragmas.rst
+++ b/docs/users_guide/exts/pragmas.rst
@@ -101,16 +101,16 @@ other compilers.
:where: declaration or module name
The ``WARNING`` pragma allows you to attach an arbitrary warning to a
- particular function, class, type, or module.
+ particular function, class, type, export field or module.
.. pragma:: DEPRECATED
:where: declaration or module name
A ``DEPRECATED`` pragma lets you specify that a particular function, class,
- type, or module is deprecated.
+ type, export or module is deprecated.
-There are two ways of using these pragmas.
+There are three ways of using these pragmas.
- You can work on an entire module thus: ::
@@ -141,6 +141,53 @@ There are two 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: ::
+
+ 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: ::
+
+ 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"
+ 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,
+ such occurences are warned about.
+
+ 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, ::
@@ -148,10 +195,12 @@ 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, and (c) uses
-in an export list. The latter reduces spurious complaints within a
-library in which one module gathers together and re-exports the exports
-of several others.
+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
*warning category* as a string literal following the ``in`` keyword. This affects the flag used to suppress
@@ -168,7 +217,7 @@ suppressed with ``-Wno-x-partial``::
Alternatively, warnings from all ``WARNING`` and ``DEPRECATED`` pragmas
regardless of category can be suppressed with
-:ghc-flag:`-Wno-extended-warnings <-Wextended-warnings>`).
+:ghc-flag:`-Wno-extended-warnings <-Wextended-warnings>`.
.. _minimal-pragma:
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 7f57eda6cab4..37ae36ae50a5 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -131,6 +131,7 @@ as ``-Wno-...`` for every individual warning in the group.
* :ghc-flag:`-Wtype-defaults`
* :ghc-flag:`-Wunused-do-bind`
* :ghc-flag:`-Wunused-record-wildcards`
+ * :ghc-flag:`-Wincomplete-export-warnings`
.. ghc-flag:: -Weverything
:shortdesc: enable all warnings supported by GHC
@@ -2467,3 +2468,33 @@ of ``-W(no-)*``.
If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice.
It turns on heavyweight intra-pass sanity-checking within GHC. (It checks GHC's
sanity, not yours.)
+
+.. ghc-flag:: -Wincomplete-export-warnings
+ :shortdesc: warn when some but not all of exports for a name are warned about
+ :type: dynamic
+ :reverse: -Wno-incomplete-export-warnings
+
+ :since: 9.8.1
+
+ Ino accordance with `GHC Proposal #134
+ <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0134-deprecating-exports-proposal.rst>`__,
+ it is now possible to deprecate certain exports of a name without deprecating the name itself.
+
+ As explained in :ref:`warning-deprecated-pragma`, when a name is exported in several ways in the same module,
+ but only some of those ways have a warning, it will not end up deprecated when imported in another module.
+
+ For example: ::
+
+ module A (x) where
+
+ x :: Int
+ x = 2
+
+ module M (
+ {-# WARNING x "deprecated" #-} x
+ module A
+ )
+ import A
+
+ When :ghc-flag:`-Wincomplete-export-warnings` is enabled, GHC warns about exports
+ that are not deprecating a name that is deprecated with another export in that module.
\ No newline at end of file
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/Makefile b/testsuite/tests/backpack/cabal/bkpcabal08/Makefile
new file mode 100644
index 000000000000..4932f7272f0b
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/Makefile
@@ -0,0 +1,21 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+SETUP=./Setup -v0
+CONFIGURE=$(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=tmp.d --prefix='$(PWD)/inst'
+
+bkpcabal08: clean
+ $(MAKE) -s --no-print-directory clean
+ '$(GHC_PKG)' init tmp.d
+ '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup
+ # typecheck
+ $(CONFIGURE)
+ $(SETUP) build
+ $(SETUP) -v1 build
+ifneq "$(CLEANUP)" ""
+ $(MAKE) -s --no-print-directory clean
+endif
+
+clean :
+ $(RM) -r tmp.d inst dist Setup$(exeext)
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/R.hs b/testsuite/tests/backpack/cabal/bkpcabal08/R.hs
new file mode 100644
index 000000000000..95d1891d4cf4
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/R.hs
@@ -0,0 +1,4 @@
+module R(y) where
+import A (x)
+import B (z)
+y = x && z
\ No newline at end of file
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/Setup.hs b/testsuite/tests/backpack/cabal/bkpcabal08/Setup.hs
new file mode 100644
index 000000000000..9a994af677b0
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/all.T b/testsuite/tests/backpack/cabal/bkpcabal08/all.T
new file mode 100644
index 000000000000..08454185c1b3
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/all.T
@@ -0,0 +1,12 @@
+if config.cleanup:
+ cleanup = 'CLEANUP=1'
+else:
+ cleanup = 'CLEANUP=0'
+
+test('bkpcabal08',
+ [extra_files(['p', 'q', 'impl', 'bkpcabal08.cabal', 'Setup.hs', 'R.hs']),
+ js_broken(22351),
+ normalise_slashes,
+ normalise_version('bkpcabal08')],
+ run_command,
+ ['$MAKE -s --no-print-directory bkpcabal08 ' + cleanup])
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.cabal b/testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.cabal
new file mode 100644
index 000000000000..0a75b0f41174
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.cabal
@@ -0,0 +1,30 @@
+cabal-version: 2.2
+name: bkpcabal08
+version: 0.1.0.0
+license: BSD-3-Clause
+author: Bartłomiej Cieślar
+build-type: Simple
+
+library impl
+ exposed-modules: A, B
+ hs-source-dirs: impl
+ build-depends: base
+ default-language: Haskell2010
+
+library p
+ signatures: A, B
+ hs-source-dirs: p
+ build-depends: base
+ default-language: Haskell2010
+
+library q
+ signatures: A, B
+ exposed-modules: M
+ hs-source-dirs: q
+ build-depends: base, p
+ default-language: Haskell2010
+
+library r
+ exposed-modules: R
+ build-depends: base, q, impl
+ default-language: Haskell2010
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout b/testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
new file mode 100644
index 000000000000..e0d3325475e5
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout
@@ -0,0 +1,25 @@
+Preprocessing library 'p' for bkpcabal08-0.1.0.0..
+Building library 'p' instantiated with
+ A = <A>
+ B = <B>
+for bkpcabal08-0.1.0.0..
+[2 of 2] Compiling B[sig] ( p/B.hsig, nothing )
+Preprocessing library 'q' for bkpcabal08-0.1.0.0..
+Building library 'q' instantiated with
+ A = <A>
+ B = <B>
+for bkpcabal08-0.1.0.0..
+[2 of 4] Compiling B[sig] ( q/B.hsig, nothing )
+[3 of 4] Compiling M ( q/M.hs, nothing ) [A changed]
+[4 of 4] Instantiating bkpcabal08-0.1.0.0-EyPgBicvfbiC7dE1n4Leie-p
+Preprocessing library 'impl' for bkpcabal08-0.1.0.0..
+Building library 'impl' for bkpcabal08-0.1.0.0..
+Preprocessing library 'q' for bkpcabal08-0.1.0.0..
+Building library 'q' instantiated with
+ A = bkpcabal08-0.1.0.0-7fVENJzzGcJGpTFnmRtPuV-impl:A
+ B = bkpcabal08-0.1.0.0-7fVENJzzGcJGpTFnmRtPuV-impl:B
+for bkpcabal08-0.1.0.0..
+[1 of 3] Compiling A[sig] ( q/A.hsig, dist/build/bkpcabal08-0.1.0.0-ECOfUnn43H71QBN16LasXC-q+GMGlyMx4Le5H1wfFVpXzYJ/A.o ) [Prelude package changed]
+[2 of 3] Compiling B[sig] ( q/B.hsig, dist/build/bkpcabal08-0.1.0.0-ECOfUnn43H71QBN16LasXC-q+GMGlyMx4Le5H1wfFVpXzYJ/B.o ) [Prelude package changed]
+Preprocessing library 'r' for bkpcabal08-0.1.0.0..
+Building library 'r' for bkpcabal08-0.1.0.0..
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/impl/A.hs b/testsuite/tests/backpack/cabal/bkpcabal08/impl/A.hs
new file mode 100644
index 000000000000..405cf98c057b
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/impl/A.hs
@@ -0,0 +1,2 @@
+module A where
+x = True
\ No newline at end of file
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/impl/B.hs b/testsuite/tests/backpack/cabal/bkpcabal08/impl/B.hs
new file mode 100644
index 000000000000..7e111444f5f7
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/impl/B.hs
@@ -0,0 +1,2 @@
+module B where
+z = False
\ No newline at end of file
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/p/A.hsig b/testsuite/tests/backpack/cabal/bkpcabal08/p/A.hsig
new file mode 100644
index 000000000000..13da166454ad
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/p/A.hsig
@@ -0,0 +1,3 @@
+signature A where
+data T
+x :: Bool
\ No newline at end of file
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/p/B.hsig b/testsuite/tests/backpack/cabal/bkpcabal08/p/B.hsig
new file mode 100644
index 000000000000..9282cdcc4af2
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/p/B.hsig
@@ -0,0 +1,4 @@
+signature B where
+import A
+y :: T
+z :: Bool
\ No newline at end of file
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/q/A.hsig b/testsuite/tests/backpack/cabal/bkpcabal08/q/A.hsig
new file mode 100644
index 000000000000..b58fdb4b3e5b
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/q/A.hsig
@@ -0,0 +1,2 @@
+signature A (x) where
+x :: Bool
\ No newline at end of file
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/q/B.hsig b/testsuite/tests/backpack/cabal/bkpcabal08/q/B.hsig
new file mode 100644
index 000000000000..beff211567d3
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/q/B.hsig
@@ -0,0 +1,2 @@
+signature B (z) where
+z :: Bool
\ No newline at end of file
diff --git a/testsuite/tests/backpack/cabal/bkpcabal08/q/M.hs b/testsuite/tests/backpack/cabal/bkpcabal08/q/M.hs
new file mode 100644
index 000000000000..769d2cdb14ea
--- /dev/null
+++ b/testsuite/tests/backpack/cabal/bkpcabal08/q/M.hs
@@ -0,0 +1,4 @@
+module M(y) where
+import A (x)
+import B (z)
+y = x && z
\ No newline at end of file
diff --git a/testsuite/tests/backpack/should_compile/all.T b/testsuite/tests/backpack/should_compile/all.T
index d9534d713086..9144fbb5cd63 100644
--- a/testsuite/tests/backpack/should_compile/all.T
+++ b/testsuite/tests/backpack/should_compile/all.T
@@ -35,7 +35,7 @@ test('bkp40', normal, backpack_compile, [''])
test('bkp41', normal, backpack_compile, [''])
test('bkp42', normal, backpack_compile, [''])
test('bkp43', normal, backpack_compile, [''])
-test('bkp44', normal, backpack_compile, [''])
+# bkp44 moved to bkpcabal08
test('bkp45', normal, backpack_compile, [''])
test('bkp46', normal, backpack_compile, [''])
test('bkp47', normal, backpack_compile, [''])
diff --git a/testsuite/tests/backpack/should_compile/bkp44.bkp b/testsuite/tests/backpack/should_compile/bkp44.bkp
deleted file mode 100644
index 06134b70863c..000000000000
--- a/testsuite/tests/backpack/should_compile/bkp44.bkp
+++ /dev/null
@@ -1,23 +0,0 @@
-unit p where
- signature A where
- data T
- x :: Bool
- signature B where
- import A
- y :: T
- z :: Bool
-unit q where
- dependency signature p[A=<A>,B=<B>]
- signature A (x) where
- signature B (z) where
- module M(y) where
- import A
- import B
- y = x && z
-unit pimpl where
- module A where
- x = True
- module B where
- z = False
-unit r where
- dependency q[A=pimpl:A,B=pimpl:B]
diff --git a/testsuite/tests/backpack/should_compile/bkp44.stderr b/testsuite/tests/backpack/should_compile/bkp44.stderr
deleted file mode 100644
index 83a8578dcd6c..000000000000
--- a/testsuite/tests/backpack/should_compile/bkp44.stderr
+++ /dev/null
@@ -1,20 +0,0 @@
-[1 of 4] Processing p
- [1 of 2] Compiling A[sig] ( p/A.hsig, nothing )
- [2 of 2] Compiling B[sig] ( p/B.hsig, nothing )
-[2 of 4] Processing q
- [1 of 4] Compiling A[sig] ( q/A.hsig, nothing )
- [2 of 4] Compiling B[sig] ( q/B.hsig, nothing )
- [3 of 4] Compiling M ( q/M.hs, nothing )
- [4 of 4] Instantiating p
-[3 of 4] Processing pimpl
- Instantiating pimpl
- [1 of 2] Compiling A ( pimpl/A.hs, bkp44.out/pimpl/A.o )
- [2 of 2] Compiling B ( pimpl/B.hs, bkp44.out/pimpl/B.o )
-[4 of 4] Processing r
- Instantiating r
- [1 of 1] Including q[A=pimpl:A,B=pimpl:B]
- Instantiating q[A=pimpl:A,B=pimpl:B]
- [1 of 3] Compiling A[sig] ( q/A.hsig, bkp44.out/q/q-BxPafal3NcFHV8AOBzU3fg/A.o )
- [2 of 3] Compiling B[sig] ( q/B.hsig, bkp44.out/q/q-BxPafal3NcFHV8AOBzU3fg/B.o )
- [3 of 3] Compiling M ( q/M.hs, bkp44.out/q/q-BxPafal3NcFHV8AOBzU3fg/M.o )
- [1 of 1] Instantiating q
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index 31f8d36bb35c..cd3455b92a88 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -1373,7 +1373,9 @@
[(L
(SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:8:19-22 })
(IEThingAbs
- (EpAnnNotUsed)
+ ((,)
+ (Nothing)
+ (EpAnnNotUsed))
(L
(SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:8:19-22 })
(IEName
diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr
index 1bd38be52a19..5fd2724f1650 100644
--- a/testsuite/tests/parser/should_compile/T14189.stderr
+++ b/testsuite/tests/parser/should_compile/T14189.stderr
@@ -186,14 +186,16 @@
(L
(SrcSpanAnn (EpAnnNotUsed) { T14189.hs:3:3-15 })
(IEThingWith
- (EpAnn
- (Anchor
- { T14189.hs:3:3-8 }
- (UnchangedAnchor))
- [(AddEpAnn AnnOpenP (EpaSpan { T14189.hs:3:10 }))
- ,(AddEpAnn AnnCloseP (EpaSpan { T14189.hs:3:15 }))]
- (EpaComments
- []))
+ ((,)
+ (Nothing)
+ (EpAnn
+ (Anchor
+ { T14189.hs:3:3-8 }
+ (UnchangedAnchor))
+ [(AddEpAnn AnnOpenP (EpaSpan { T14189.hs:3:10 }))
+ ,(AddEpAnn AnnCloseP (EpaSpan { T14189.hs:3:15 }))]
+ (EpaComments
+ [])))
(L
(SrcSpanAnn (EpAnnNotUsed) { T14189.hs:3:3-8 })
(IEName
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index de88dea3f050..cab3e0631344 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -729,6 +729,11 @@ PprCommentPlacement2:
$(CHECK_PPR) $(LIBDIR) PprCommentPlacement2.hs
$(CHECK_EXACT) $(LIBDIR) PprCommentPlacement2.hs
+.PHONY: PprExportWarn
+PprExportWarn:
+ $(CHECK_PPR) $(LIBDIR) PprExportWarn.hs
+ $(CHECK_EXACT) $(LIBDIR) PprExportWarn.hs
+
.PHONY: Test20243
Test20243:
$(CHECK_PPR) $(LIBDIR) Test20243.hs
diff --git a/testsuite/tests/printer/PprExportWarn.hs b/testsuite/tests/printer/PprExportWarn.hs
new file mode 100644
index 000000000000..d68cc0606023
--- /dev/null
+++ b/testsuite/tests/printer/PprExportWarn.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE PatternSynonyms #-}
+module PprExportWarning (
+ {-# WARNING "Just because I can but a really long message" #-}
+ Foo(..),
+ {-# DEPRECATED "Just because" #-}
+ reallyreallyreallyreallyreallyreallyreallyreallylongname,
+ {-# DEPRECATED "Just because" #-} Bar(Bar1, Bar2),
+ {-# WARNING "Just because" #-} name,
+ {-# DEPRECATED ["Reason",
+ "Another reason"] #-}
+ Baz,
+ {-# DEPRECATED [ ] #-} module GHC,
+ {-# WARNING "Dummy Pattern" #-} pattern Dummy,
+ Foo'(..),
+ reallyreallyreallyreallyreallyreallyreallyreallylongname',
+ Bar'(Bar1, Bar2), name', Baz', module Data.List, pattern Dummy'
+ ) where
+import GHC
+import Data.List
+data Foo = Foo1 | Foo2 | Foo3
+reallyreallyreallyreallyreallyreallyreallyreallylongname = undefined
+data Bar = Bar1 | Bar2 | Bar3
+name = undefined
+data Baz
+pattern Dummy = Foo1
+data Foo' = Foo1 | Foo2 | Foo3
+reallyreallyreallyreallyreallyreallyreallyreallylongname' = undefined
+data Bar' = Bar1 | Bar2 | Bar3
+name' = undefined
+data Baz'
+pattern Dummy' = Foo1
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index e9de8ea590d1..b401556590ed 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -171,6 +171,7 @@ test('PprT13747', [ignore_stderr, req_ppr_deps], makefile_test, ['PprT13747'])
test('PprBracesSemiDataDecl', [ignore_stderr, req_ppr_deps], makefile_test, ['PprBracesSemiDataDecl'])
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('Test20243', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20243'])
test('Test20247', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20247'])
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings1.hs b/testsuite/tests/rename/should_compile/ExportWarnings1.hs
new file mode 100644
index 000000000000..c78a2cff7ca1
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings1.hs
@@ -0,0 +1,5 @@
+-- Case for explicit mentions of imports
+module ExportWarnings1 () where
+
+import ExportWarnings_aux (x, S(S1))
+import ExportWarnings_base (x, T(T1), V, B)
\ No newline at end of file
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings1.stderr b/testsuite/tests/rename/should_compile/ExportWarnings1.stderr
new file mode 100644
index 000000000000..7870a128f1af
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings1.stderr
@@ -0,0 +1,30 @@
+
+ExportWarnings1.hs:4:28: warning: [GHC-63394] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of ‘x’ (imported from ExportWarnings_aux): "warn"
+
+ExportWarnings1.hs:4:31: warning: [GHC-63394] [-Wx-custom (in -Wextended-warnings)]
+ In the use of data constructor ‘S1’
+ (imported from ExportWarnings_aux):
+ "is
+ deprecated"
+
+ExportWarnings1.hs:4:31: warning: [GHC-63394] [-Wx-custom (in -Wextended-warnings)]
+ In the use of type constructor or class ‘S’
+ (imported from ExportWarnings_aux):
+ "is
+ deprecated"
+
+ExportWarnings1.hs:5:32: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of data constructor ‘T1’
+ (imported from ExportWarnings_base):
+ Deprecated: "warn"
+
+ExportWarnings1.hs:5:32: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of type constructor or class ‘T’
+ (imported from ExportWarnings_base):
+ Deprecated: "warn"
+
+ExportWarnings1.hs:5:39: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of type constructor or class ‘V’
+ (imported from ExportWarnings_base):
+ Deprecated: ""
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings2.hs b/testsuite/tests/rename/should_compile/ExportWarnings2.hs
new file mode 100644
index 000000000000..4ad6d88ae9c4
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings2.hs
@@ -0,0 +1,7 @@
+-- Case for no explicit mention but usage
+module ExportWarnings2 () where
+
+import ExportWarnings_aux
+import ExportWarnings_aux2
+foo = x
+type U = V
\ No newline at end of file
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings2.stderr b/testsuite/tests/rename/should_compile/ExportWarnings2.stderr
new file mode 100644
index 000000000000..5891b1ec085f
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings2.stderr
@@ -0,0 +1,12 @@
+
+ExportWarnings_aux2.hs:3:5: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of type constructor or class ‘V’
+ (imported from ExportWarnings_base):
+ Deprecated: ""
+
+ExportWarnings2.hs:6:7: warning: [GHC-63394] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of ‘x’ (imported from ExportWarnings_aux): "warn"
+
+ExportWarnings2.hs:6:7: warning: [GHC-63394] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of ‘x’ (imported from ExportWarnings_aux2):
+ "different warn"
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings3.hs b/testsuite/tests/rename/should_compile/ExportWarnings3.hs
new file mode 100644
index 000000000000..3be7e924abc7
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings3.hs
@@ -0,0 +1,14 @@
+-- Case for explicit usage of imports + usage when not all import paths are deprecated
+module ExportWarnings3 () where
+
+import ExportWarnings_base
+import ExportWarnings_aux
+foo = x
+
+bar :: S -> Int -> T
+bar S1 v = T1 v
+bar _ v = T2 v
+
+
+baz :: V -> V
+baz = id
\ No newline at end of file
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings3.stderr b/testsuite/tests/rename/should_compile/ExportWarnings3.stderr
new file mode 100644
index 000000000000..230a4832c302
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings3.stderr
@@ -0,0 +1,37 @@
+
+ExportWarnings3.hs:8:8: warning: [GHC-63394] [-Wx-custom (in -Wextended-warnings)]
+ In the use of type constructor or class ‘S’
+ (imported from ExportWarnings_aux):
+ "is
+ deprecated"
+
+ExportWarnings3.hs:8:20: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of type constructor or class ‘T’
+ (imported from ExportWarnings_base):
+ Deprecated: "warn"
+
+ExportWarnings3.hs:9:5: warning: [GHC-63394] [-Wx-custom (in -Wextended-warnings)]
+ In the use of data constructor ‘S1’
+ (imported from ExportWarnings_aux):
+ "is
+ deprecated"
+
+ExportWarnings3.hs:9:12: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of data constructor ‘T1’
+ (imported from ExportWarnings_base):
+ Deprecated: "warn"
+
+ExportWarnings3.hs:10:12: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of data constructor ‘T2’
+ (imported from ExportWarnings_base):
+ Deprecated: "warn"
+
+ExportWarnings3.hs:13:8: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of type constructor or class ‘V’
+ (imported from ExportWarnings_base):
+ Deprecated: ""
+
+ExportWarnings3.hs:13:13: warning: [GHC-68441] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of type constructor or class ‘V’
+ (imported from ExportWarnings_base):
+ Deprecated: ""
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings4.hs b/testsuite/tests/rename/should_compile/ExportWarnings4.hs
new file mode 100644
index 000000000000..c1b8f9cee8ed
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings4.hs
@@ -0,0 +1,6 @@
+-- Case for when not all import paths are deprecated but the name is qualified
+module ExportWarnings4 () where
+
+import ExportWarnings_base
+import ExportWarnings_aux
+foo = ExportWarnings_aux.x
\ No newline at end of file
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings4.stderr b/testsuite/tests/rename/should_compile/ExportWarnings4.stderr
new file mode 100644
index 000000000000..892ff8192e63
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings4.stderr
@@ -0,0 +1,3 @@
+
+ExportWarnings4.hs:6:7: warning: [GHC-63394] [-Wdeprecations (in -Wextended-warnings)]
+ In the use of ‘x’ (imported from ExportWarnings_aux): "warn"
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings5.hs b/testsuite/tests/rename/should_compile/ExportWarnings5.hs
new file mode 100644
index 000000000000..d4aedd9d6f2c
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings5.hs
@@ -0,0 +1,5 @@
+-- Case for when names are mentioned in the hiding clauses
+module ExportWarnings5 () where
+
+import ExportWarnings_aux hiding (x, S(..))
+import ExportWarnings_base hiding (x, T(T2, y), V)
\ No newline at end of file
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings6.hs b/testsuite/tests/rename/should_compile/ExportWarnings6.hs
new file mode 100644
index 000000000000..bc18b37346c0
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings6.hs
@@ -0,0 +1,2 @@
+module ExportWarnings6 ({-# WARNING "warn" #-} x, x) where
+x = 1
\ No newline at end of file
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings6.stderr b/testsuite/tests/rename/should_compile/ExportWarnings6.stderr
new file mode 100644
index 000000000000..0893d927471c
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings6.stderr
@@ -0,0 +1,7 @@
+
+ExportWarnings6.hs:1:25: warning: [GHC-94721] [-Wincomplete-export-warnings (in -Wall)]
+ ‘x’ will not have its export warned about
+ missing export warning at ExportWarnings6.hs:1:51
+
+ExportWarnings6.hs:1:51: warning: [GHC-47854] [-Wduplicate-exports (in -Wdefault)]
+ ‘x’ is exported by ‘x’ and ‘{-# WARNING "warn" #-} x’
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings_aux.hs b/testsuite/tests/rename/should_compile/ExportWarnings_aux.hs
new file mode 100644
index 000000000000..c8f38debe51d
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings_aux.hs
@@ -0,0 +1,7 @@
+module ExportWarnings_aux (
+ {-# WARNING "warn" #-} x,
+ {-# WARNING in "x-custom" ["is", "deprecated"] #-} S(S1),
+ ) where
+import ExportWarnings_base (x)
+
+data S = S1 | S2
\ No newline at end of file
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings_aux2.hs b/testsuite/tests/rename/should_compile/ExportWarnings_aux2.hs
new file mode 100644
index 000000000000..c9327b20a0ca
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings_aux2.hs
@@ -0,0 +1,5 @@
+module ExportWarnings_aux2 (
+ {-# WARNING "different warn" #-} x,
+ V
+ ) where
+import ExportWarnings_base
\ No newline at end of file
diff --git a/testsuite/tests/rename/should_compile/ExportWarnings_base.hs b/testsuite/tests/rename/should_compile/ExportWarnings_base.hs
new file mode 100644
index 000000000000..cb4a0971c8b6
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/ExportWarnings_base.hs
@@ -0,0 +1,14 @@
+module ExportWarnings_base (
+ x,
+ {-# DEPRECATED "warn" #-} T(..),
+ {-# WARNING "no warn" #-} B(B1),
+ B(B2),
+ {-# DEPRECATED [] #-} V
+ ) where
+
+x :: Bool
+x = True
+
+data T = T1 {y :: Int} | T2 {y :: Int}
+data B = B1 | B2
+newtype V = V ()
\ No newline at end of file
diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T
index ad9301b273a1..1eefe0b0806d 100644
--- a/testsuite/tests/rename/should_compile/all.T
+++ b/testsuite/tests/rename/should_compile/all.T
@@ -214,3 +214,9 @@ test('T23318', normal, compile, ['-Wduplicate-exports'])
test('T23434', normal, compile, [''])
test('T23510b', normal, compile, [''])
test('T23512b', normal, compile, [''])
+test('ExportWarnings1', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_aux.hs']), multimod_compile, ['ExportWarnings1', '-v0 -Wno-duplicate-exports -Wx-custom'])
+test('ExportWarnings2', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_aux.hs', 'ExportWarnings_aux2.hs']), multimod_compile, ['ExportWarnings2', '-v0 -Wno-duplicate-exports -Wx-custom'])
+test('ExportWarnings3', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_aux.hs']), multimod_compile, ['ExportWarnings3', '-v0 -Wno-duplicate-exports -Wx-custom'])
+test('ExportWarnings4', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_aux.hs']), multimod_compile, ['ExportWarnings4', '-v0 -Wno-duplicate-exports -Wx-custom'])
+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'])
diff --git a/testsuite/tests/rename/should_fail/DifferentExportWarnings.hs b/testsuite/tests/rename/should_fail/DifferentExportWarnings.hs
new file mode 100644
index 000000000000..a9ae815f3d18
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/DifferentExportWarnings.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE PatternSynonyms #-}
+module DifferentExportWarnings (
+ {-# DEPRECATED "test" #-} Foo(..),
+ {-# DEPRECATED "test" #-} Foo(Foo1),
+ {-# WARNING "test" #-} Foo(Foo2),
+ {-# WARNING in "x-cat" "test2" #-} Bar(Dummy),
+ {-# WARNING in "x-cat2" "test2" #-} Bar,
+ {-# WARNING "test3-a" #-} module DifferentExportWarningsA,
+ {-# WARNING "test3-b" #-} module DifferentExportWarningsA,
+ {-# WARNING "test3-b" #-} x
+ ) where
+
+import DifferentExportWarningsA (x, y)
+
+data Foo = Foo1 | Foo2
+data Bar = Bar1 | Bar2
+pattern Dummy = Bar1
\ No newline at end of file
diff --git a/testsuite/tests/rename/should_fail/DifferentExportWarnings.stderr b/testsuite/tests/rename/should_fail/DifferentExportWarnings.stderr
new file mode 100644
index 000000000000..4385f9a9c209
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/DifferentExportWarnings.stderr
@@ -0,0 +1,21 @@
+
+DifferentExportWarnings.hs:5:5: error: [GHC-92878]
+ ‘Foo2’ exported with different error messages
+ at DifferentExportWarnings.hs:3:5-37
+
+DifferentExportWarnings.hs:5:5: error: [GHC-92878]
+ ‘Foo’ exported with different error messages
+ at DifferentExportWarnings.hs:3:5-37
+ DifferentExportWarnings.hs:4:5-39
+
+DifferentExportWarnings.hs:7:5: error: [GHC-92878]
+ ‘Bar’ exported with different error messages
+ at DifferentExportWarnings.hs:6:5-49
+
+DifferentExportWarnings.hs:9:5: error: [GHC-92878]
+ ‘y’ exported with different error messages
+ at DifferentExportWarnings.hs:8:5-61
+
+DifferentExportWarnings.hs:10:5: error: [GHC-92878]
+ ‘x’ exported with different error messages
+ at DifferentExportWarnings.hs:8:5-61
diff --git a/testsuite/tests/rename/should_fail/DifferentExportWarningsA.hs b/testsuite/tests/rename/should_fail/DifferentExportWarningsA.hs
new file mode 100644
index 000000000000..1e7d7385033e
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/DifferentExportWarningsA.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE PatternSynonyms #-}
+module DifferentExportWarningsA (x, y, z) where
+
+x = undefined
+y = undefined
+z = undefined
\ No newline at end of file
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index 4e97f45cfdf4..2eccda4e9e61 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -204,3 +204,4 @@ test('T16635a', normal, compile_fail, [''])
test('T16635b', normal, compile_fail, [''])
test('T16635c', normal, compile_fail, [''])
test('T23512a', normal, compile_fail, [''])
+test('DifferentExportWarnings', normal, multimod_compile_fail, ['DifferentExportWarnings', '-v0'])
diff --git a/testsuite/tests/showIface/PragmaDocs.hs b/testsuite/tests/showIface/PragmaDocs.hs
index 3e7a068d71a8..e3b3ecf6174c 100644
--- a/testsuite/tests/showIface/PragmaDocs.hs
+++ b/testsuite/tests/showIface/PragmaDocs.hs
@@ -1,4 +1,4 @@
-module PragmaDocs where
+module PragmaDocs ({-# DEPRECATED "Do not use" #-} contains) where
{-# DEPRECATED contains "Use `elem` instead." #-}
contains :: (Eq a, Foldable f) => f a -> a -> Bool
diff --git a/testsuite/tests/showIface/PragmaDocs.stdout b/testsuite/tests/showIface/PragmaDocs.stdout
index b2a9c929c6d4..e905057dd825 100644
--- a/testsuite/tests/showIface/PragmaDocs.stdout
+++ b/testsuite/tests/showIface/PragmaDocs.stdout
@@ -1,6 +1,8 @@
-Warnings: x "These are useless"
- y "These are useless"
- contains "Use `elem` instead."
+Warnings:
+ Deprecated names: x "These are useless"
+ y "These are useless"
+ contains "Use `elem` instead."
+ Deprecated exports: contains "Do not use"
trusted: none
require own pkg trusted: False
docs:
@@ -13,10 +15,6 @@ docs:
documentation structure:
avails:
[contains]
- avails:
- [x]
- avails:
- [y]
named chunks:
haddock options:
language:
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 30a8831ddfec..0bca51750718 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -4467,37 +4467,41 @@ instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where
instance ExactPrint (IE GhcPs) where
getAnnotationEntry (IEVar _ _) = NoEntryVal
- getAnnotationEntry (IEThingAbs an _) = fromAnn an
- getAnnotationEntry (IEThingAll an _) = fromAnn an
- getAnnotationEntry (IEThingWith an _ _ _) = fromAnn an
- getAnnotationEntry (IEModuleContents an _)= fromAnn an
+ getAnnotationEntry (IEThingAbs (_, an) _) = fromAnn an
+ getAnnotationEntry (IEThingAll (_, an) _) = fromAnn an
+ getAnnotationEntry (IEThingWith (_, an) _ _ _) = fromAnn an
+ getAnnotationEntry (IEModuleContents (_, an) _)= fromAnn an
getAnnotationEntry (IEGroup _ _ _) = NoEntryVal
getAnnotationEntry (IEDoc _ _) = NoEntryVal
getAnnotationEntry (IEDocNamed _ _) = NoEntryVal
setAnnotationAnchor a@(IEVar _ _) _ _s = a
- setAnnotationAnchor (IEThingAbs an a) anc cs = (IEThingAbs (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (IEThingAll an a) anc cs = (IEThingAll (setAnchorEpa an anc cs) a)
- setAnnotationAnchor (IEThingWith an a b c) anc cs = (IEThingWith (setAnchorEpa an anc cs) a b c)
- setAnnotationAnchor (IEModuleContents an a) anc cs = (IEModuleContents (setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (IEThingAbs (depr, an) a) anc cs = (IEThingAbs (depr, setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (IEThingAll (depr, an) a) anc cs = (IEThingAll (depr, setAnchorEpa an anc cs) a)
+ setAnnotationAnchor (IEThingWith (depr, an) a b c) anc cs = (IEThingWith (depr, setAnchorEpa an anc cs) a b c)
+ setAnnotationAnchor (IEModuleContents (depr, an) a) anc cs = (IEModuleContents (depr, setAnchorEpa an anc cs) a)
setAnnotationAnchor a@(IEGroup _ _ _) _ _s = a
setAnnotationAnchor a@(IEDoc _ _) _ _s = a
setAnnotationAnchor a@(IEDocNamed _ _) _ _s = a
- exact (IEVar x ln) = do
+ exact (IEVar depr ln) = do
+ depr' <- markAnnotated depr
ln' <- markAnnotated ln
- return (IEVar x ln')
- exact (IEThingAbs x thing) = do
+ return (IEVar depr' ln')
+ exact (IEThingAbs (depr, an) thing) = do
+ depr' <- markAnnotated depr
thing' <- markAnnotated thing
- return (IEThingAbs x thing')
- exact (IEThingAll an thing) = do
+ return (IEThingAbs (depr', an) thing')
+ exact (IEThingAll (depr, an) thing) = do
+ depr' <- markAnnotated depr
thing' <- markAnnotated thing
an0 <- markEpAnnL an lidl AnnOpenP
an1 <- markEpAnnL an0 lidl AnnDotdot
an2 <- markEpAnnL an1 lidl AnnCloseP
- return (IEThingAll an2 thing')
+ return (IEThingAll (depr', an2) thing')
- exact (IEThingWith an thing wc withs) = do
+ exact (IEThingWith (depr, an) thing wc withs) = do
+ depr' <- markAnnotated depr
thing' <- markAnnotated thing
an0 <- markEpAnnL an lidl AnnOpenP
(an1, wc', withs') <-
@@ -4513,12 +4517,13 @@ instance ExactPrint (IE GhcPs) where
as' <- markAnnotated as
return (an2, wc, bs'++as')
an2 <- markEpAnnL an1 lidl AnnCloseP
- return (IEThingWith an2 thing' wc' withs')
+ return (IEThingWith (depr', an2) thing' wc' withs')
- exact (IEModuleContents an m) = do
+ exact (IEModuleContents (depr, an) m) = do
+ depr' <- markAnnotated depr
an0 <- markEpAnnL an lidl AnnModule
m' <- markAnnotated m
- return (IEModuleContents an0 m')
+ return (IEModuleContents (depr', an0) m')
exact x = error $ "missing match for IE:" ++ showAst x
@@ -4849,7 +4854,7 @@ getPosP = gets epPos
setPosP :: (Monad m, Monoid w) => Pos -> EP w m ()
setPosP l = do
- -- debugM $ "setPosP:" ++ show l
+ debugM $ "setPosP:" ++ show l
modify (\s -> s {epPos = l})
getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe Anchor)
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 74525dd5f9cd..b498f6cc48af 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -896,8 +896,8 @@ addHiding1 _libdir (L l p) = do
[L li imp1,imp2] = hsmodImports p
n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1"))
n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2"))
- v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1)))
- v2 = L ( noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2)))
+ v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar Nothing (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1)))
+ v2 = L ( noAnnSrcSpanDP0 l2) (IEVar Nothing (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2)))
impHiding = L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan l0) m0)
(AnnList Nothing
(Just (AddEpAnn AnnOpenP d1))
@@ -933,8 +933,8 @@ addHiding2 _libdir top = do
emptyComments) (locA lh))
n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1"))
n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2"))
- v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1)))
- v2 = L ( noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2)))
+ v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar Nothing (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1)))
+ v2 = L ( noAnnSrcSpanDP0 l2) (IEVar Nothing (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2)))
L ln n = last ns
n' = L (addComma ln) n
imp1' = imp1 { ideclImportList = Just (EverythingBut, L lh' (init ns ++ [n',v1,v2]))}
diff --git a/utils/haddock b/utils/haddock
index bfb52adefa02..081aa819f292 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit bfb52adefa028f541672623321eb1b3d21dd2547
+Subproject commit 081aa819f292323387c84bbc2192215e88df6efe
--
GitLab