diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 66432aa1634352e1c814c993910dcfd85eee846a..cb4ba5f1e9843dc19dfb31491ce26e1b20de8b98 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 e06d6e9d18108d79ec483736df25a4d0f7f3bab6..fec6508b6d68c7b803a1e7b2463b2d2e4fec4906 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 f7c32113debb53c26e922e565043ca4fe2a2d4e1..6331774b3f6720ef3d7847dd95267754022c297d 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 06a6cc783ea45b8316b2a2cf69752c4df3b6fdb9..5e25893cb962eb50e150cea80f7be2edb0d9b637 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 dd84d399f59bfe8120b04dcc4c0a624a7c9bc0c7..2dc05841f78d316240730d9003c92d07d7bb2f44 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 48b24b903b785a5a2a8fa6bab0e0ab05bafce31b..da47ecd8d59fd269f7166efc29840c139c35fcdc 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 39579b69b2b89b714fcf730e10a5cc347337be98..84716f9ad32e80eb5a2534a9416f15aec1c7fce4 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 a61a1335743cd4c14fa8cdc1bb548295d6d39793..37844ff46f97f976dbc6c0a164ad7012a5b2a334 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 c5bc296441c5698b92d6a1444a1fdc2af97b4b23..d37744ab413685d33338567d3e09a27761831b35 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 ab70fe462c3f0fdfb93ff639891fde8384040e43..50ad92b792cea1c6f8b86a36e26f223389b20897 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 d7a5fa483324100ade6e5c214b47b4237168b3e0..ebc9f4720c26ea5d434115a8699fa2282c5d00b2 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 79df35d19e80d4357b6314c9940299fd69bb7ffe..503700d8d87875423c77faa6beac7006eb8e6fa8 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 7ee4b09a851cb5920b882a8811d8f89f33712e17..312629c0fad457fcd65b24367693f304761fa171 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 3137195864f3b49dda8258b00017ec114d3313e3..e7fd7a9022d954a4bf05575a2bc665e878a45e0b 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 5d452803eb7a0fbfed6fcbd7e90357875ad93730..4de575bbfd0f0397c280b8e033371bdce0016626 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 cd94a3fed4b0130f1c773659d42ccc03e5f1cbdd..f3dc1d10f3d5d717fd65bbca9a9cbb76fcd1488b 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 640104256e731d5ec1984b2bc0462e69674f8d28..8ace4e0aa7bb2385d17c0b0fd4313933c7742d04 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 883543499f0a2d10e1fb5eab16414b8b328e658b..2953f1281f1be4fd4b5084eb53966e998679c6e0 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 8fae1f31b16edcaa501c1d9ad445f3b3d4274604..a22ff699d16ca245e9127488aa929f0eda2f2a16 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 724ebee1b957f0ad6357664b5b331fbb025b2263..64e3df216fa49b03f33ae83191646b7cfe3d714e 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 0c7cb0cc3598932d9ad0cb31eff5a6766f5bd365..da38736dbfc7982c7307c63acb09ebdf7c91bd4b 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 b82678e4ee3fbe9c9e3f38c3a60c2d2449d4352b..b1b69868fe80ee7d4200683a5164007e61c0e409 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 be9049a20923d83534af09ee58c822c3fc55a155..2dd212b95742541f7922eac7477a042ca9af07c1 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 794e0862aec10d0f3c7b68713c51b87edd153651..0a9c053eb3e78e8dc2b6613742d4c8814e0133af 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 49913fd2fa73a963aef7b3c67b23fac67b64ec21..39a4e12e69926a0d3ac8c1089c993c78768809be 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 f96d3957fb6b484b28914201f27ca2fa8444f237..7aa3f302d86c86d83719e2547725f6e3ec98d1d3 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 17be091c74d2864057284b385b6f382a3dda2708..c77dd6ba53e986150054c1aacf9af28bab600545 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 8bdba40bbabb4c03dd11a43c6f367cc86cf08439..0a6b220be6c333c81ef244a28c6d9f27a8659f0a 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 ee49baf55412df3389dfe87d086e0e261f3b7de7..ed122e1037307cd730e7fed869335b883ab28caf 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 cd1e414d5aff21a37ce6f39e8e7f61dafb811849..95e564109f2db9ddfcfe5776812ef60482418878 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 2c8c5d47591f2ee1f3feb3973615a716ae143e01..aff9fc253a7e21d955c2f7f7de8f9c72042dfc14 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 7f57eda6cab4f44c90bf219367a7d3689314aa75..37ae36ae50a551b4cad78d17fefeb26763228e34 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 0000000000000000000000000000000000000000..4932f7272f0bdb091f911c199a417136b005a9cc
--- /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 0000000000000000000000000000000000000000..95d1891d4cf475a804858acecec96b413e613a68
--- /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 0000000000000000000000000000000000000000..9a994af677b0dfd41b4e3b76b3e7e604003d64e1
--- /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 0000000000000000000000000000000000000000..08454185c1b38f7fce5cb0f3615f64fee5238d87
--- /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 0000000000000000000000000000000000000000..0a75b0f41174c25b69821ebb0d5f43914e1a5be1
--- /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 0000000000000000000000000000000000000000..e0d3325475e53e471beb0c89e077578097ab6625
--- /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 0000000000000000000000000000000000000000..405cf98c057b23c26dafbd5e64e780f63252e423
--- /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 0000000000000000000000000000000000000000..7e111444f5f7f8667c0f5942efbddaa8f242c35e
--- /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 0000000000000000000000000000000000000000..13da166454ad90529f3f61ae2d85ac132842b10e
--- /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 0000000000000000000000000000000000000000..9282cdcc4af262ac4b21b079c25ea6c2fe152ea8
--- /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 0000000000000000000000000000000000000000..b58fdb4b3e5b3a32721eb469874d43bd08242fcb
--- /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 0000000000000000000000000000000000000000..beff211567d3e3a94ca1ff900304c3aa78d37a56
--- /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 0000000000000000000000000000000000000000..769d2cdb14ea92100cdec52be5485940546b95a8
--- /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 d9534d713086b4d4527c13ebd4ee6506e3bf9144..9144fbb5cd63e2b24ada7103a7f49f44ddd0332d 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 06134b70863c5dd33b00896e289df1c17dbb0bcb..0000000000000000000000000000000000000000
--- 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 83a8578dcd6caf5aaf2d10f66dd2c68c4a51aee8..0000000000000000000000000000000000000000
--- 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 31f8d36bb35cde2bf574626780be7ad3b786b2d6..cd3455b92a8887934e74e5db1fc46e6582571028 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 1bd38be52a19045ca956b2ce5ee081ad74581b98..5fd2724f165014f6cb34b2704703e3857bcaeba1 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 de88dea3f050a65310220f7959a9a54298601261..cab3e0631344f4586c74414a1eac58cf75342bfd 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 0000000000000000000000000000000000000000..d68cc06060233b68dcb2307b63e0dfbb8248d645
--- /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 e9de8ea590d1187c58a756345bf33e6f3430dc15..b401556590ed96d2b1794e9ef096695385afcdf9 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 0000000000000000000000000000000000000000..c78a2cff7ca139d60bfc2f4e9d9616e07cb59547
--- /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 0000000000000000000000000000000000000000..7870a128f1afc71529d91f31ea0d5a2a5886cb1d
--- /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 0000000000000000000000000000000000000000..4ad6d88ae9c46817e841a31a4e2963032550d012
--- /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 0000000000000000000000000000000000000000..5891b1ec085f310ffe20ed24852f5088e4e38d28
--- /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 0000000000000000000000000000000000000000..3be7e924abc7b3f59befacb5fd6e495262bd22b4
--- /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 0000000000000000000000000000000000000000..230a4832c302b620e74ef4f4e93acb13ab37bbd0
--- /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 0000000000000000000000000000000000000000..c1b8f9cee8ed5b458512bce78e9f23c338b61449
--- /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 0000000000000000000000000000000000000000..892ff8192e639058111f7bc46b105f651f8d5f98
--- /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 0000000000000000000000000000000000000000..d4aedd9d6f2c651536a74ed985543dc2919c3772
--- /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 0000000000000000000000000000000000000000..bc18b37346c03a2d824d0a1e43ef02229795d22b
--- /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 0000000000000000000000000000000000000000..0893d927471cac3489e11a7554e274f529843dfb
--- /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 0000000000000000000000000000000000000000..c8f38debe51d3e0fe68964b973bc97b88687031b
--- /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 0000000000000000000000000000000000000000..c9327b20a0ca55204179f2c0078f76ecf6ac6993
--- /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 0000000000000000000000000000000000000000..cb4a0971c8b6aa184fd363f6eff62063b381c1b7
--- /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 ad9301b273a17aa37e753e359d857679bdff9973..1eefe0b0806db8448242d99df562e532e2673aa6 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 0000000000000000000000000000000000000000..a9ae815f3d18e56d30dc1a7d29cc0d96c556d483
--- /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 0000000000000000000000000000000000000000..4385f9a9c209f2ace7fab2f33c91d74da5061c73
--- /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 0000000000000000000000000000000000000000..1e7d7385033e51171dbbb5d7cb8d3998ae91c923
--- /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 4e97f45cfdf44f3a3f9ab45517c150580e3ff5c1..2eccda4e9e610a5567f21f854f34aa6f99747134 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 3e7a068d71a85c74eeff9d5aa97b0564600d7665..e3b3ecf6174c72a4b35c46973bb90b8bf7e4febe 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 b2a9c929c6d477e110d386d4fbb8cd4c6a08e1f7..e905057dd8253b6712aa6593263789f68a038f58 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 30a8831ddfec71b7ab548c912797adbaad461b92..0bca517507186e35c205a4522e2f478f2e456f47 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 74525dd5f9cd4792d2f08a354323c47155813388..b498f6cc48af03c50fa8a25e2a1bb06d54a11f26 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 bfb52adefa028f541672623321eb1b3d21dd2547..081aa819f292323387c84bbc2192215e88df6efe 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit bfb52adefa028f541672623321eb1b3d21dd2547
+Subproject commit 081aa819f292323387c84bbc2192215e88df6efe