Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b14d8d59 by Alan Zimmerman at 2026-08-05T14:55:46-04:00 EPA: Remove LocatedP, last use in WarningTxt The last step of removing LocatedP, by moving the AnnPragma for WarningTxt into its TTG extension point instead. This also allows us to remove LocatedP and SrcSpanAnnP - - - - - 9 changed files: - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Warnings.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Unit/Module/Warnings.hs - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Builtin/Utils.hs ===================================== @@ -301,7 +301,7 @@ ghcPrimWarns = WarnSome [] where mk_txt msg = - DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText (fastStringToShortText msg)) []] + DeprecatedTxt (NoSourceText, noAnn) [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText (fastStringToShortText msg)) []] mk_decl_dep (occ, msg) = (occ, mk_txt msg) ghcPrimFixities :: [(OccName,Fixity)] ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1043,7 +1043,7 @@ cidDeprecation :: forall p. IsPass p cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) where decl_deprecation :: GhcPass p -> ClsInstDecl (GhcPass p) - -> Maybe (LocatedP (WarningTxt (GhcPass p))) + -> Maybe (LocatedA (WarningTxt (GhcPass p))) decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _) } ) = depr decl_deprecation GhcRn (ClsInstDecl{ cid_ext = (depr, _) }) @@ -1242,7 +1242,7 @@ derivDeprecation :: forall p. IsPass p derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) where decl_deprecation :: GhcPass p -> DerivDecl (GhcPass p) - -> Maybe (LocatedP (WarningTxt (GhcPass p))) + -> Maybe (LocatedA (WarningTxt (GhcPass p))) decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) }) = depr decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) }) ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -99,7 +99,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `ext2Q` located `extQ` srcSpanAnnA - `extQ` srcSpanAnnP `extQ` srcSpanAnnN `extQ` srcSpanAnnBF @@ -409,9 +408,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 srcSpanAnnA :: EpAnn [TrailingAnn] -> SDoc srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") - srcSpanAnnP :: EpAnn AnnPragma -> SDoc - srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") - srcSpanAnnN :: EpAnn NameAnn -> SDoc srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -83,7 +83,7 @@ import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) import GHC.Stg.EnforceEpt.TagSig -import GHC.Parser.Annotation (noLocA) +import GHC.Parser.Annotation (noLocA, noAnn) import GHC.Hs.Extension ( GhcPass, GhcRn, GhcTc ) import GHC.Hs.Decls.Overlap ( OverlapFlag ) import GHC.Hs.Doc ( WithHsDocIdentifiers(..) ) @@ -666,8 +666,8 @@ fromIfaceWarnings = \case fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn fromIfaceWarningTxt = \case - IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) - IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfWarningTxt src mb_cat strs -> WarningTxt (src, noAnn) (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfDeprecatedTxt src strs -> DeprecatedTxt (src, noAnn) (noLocA <$> map fromIfaceStringLiteralWithNames strs) fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers (StringLiteral GhcRn) GhcRn fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLocA names) ===================================== compiler/GHC/Iface/Warnings.hs ===================================== @@ -22,12 +22,11 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds' ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds] toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt -toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) -toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (WarningTxt (src, _) mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (DeprecatedTxt (src, _) strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) toIfaceStringLiteralWithNames :: WithHsDocIdentifiers (StringLiteral GhcRn) GhcRn -> (IfaceStringLiteral, [IfExtName]) toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names) toIfaceStringLiteral :: StringLiteral GhcRn -> IfaceStringLiteral -toIfaceStringLiteral sLit = - IfStringLiteral (stringLitSourceText sLit) (sl_fs sLit) +toIfaceStringLiteral sLit = IfStringLiteral (stringLitSourceText sLit) (sl_fs sLit) ===================================== compiler/GHC/Parser.y ===================================== @@ -2077,11 +2077,13 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } : '{-# DEPRECATED' strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (snd $ unLoc $2)) - (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> $ + DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) + (snd $ unLoc $2))} | '{-# WARNING' warning_category strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (snd $ unLoc $3)) - (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)} + {% fmap Just $ amsA' (sLL $1 $> $ + WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn) + $2 (snd $ unLoc $3))} | {- empty -} { Nothing } warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) } @@ -2110,7 +2112,7 @@ warning :: { OrdList (LWarnDecl GhcPs) } : warning_category namespace_spec namelist strings {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4) (Warning (fst $ unLoc $4) (unLoc $2) (unLoc $3) - (WarningTxt NoSourceText $1 (snd $ unLoc $4)))) } + (WarningTxt (NoSourceText, noAnn) $1 (snd $ unLoc $4)))) } namespace_spec :: { Located (NamespaceSpecifier GhcPs) } : 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) } @@ -2138,7 +2140,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } deprecation :: { OrdList (LWarnDecl GhcPs) } : namespace_spec namelist strings {% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (fst $ unLoc $3) (unLoc $1) (unLoc $2) - (DeprecatedTxt NoSourceText $ snd $ unLoc $3))) } + (DeprecatedTxt (NoSourceText, noAnn) $ snd $ unLoc $3))) } strings :: { Located ((EpToken "[", EpToken "]"), [LocatedA (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs)]) } : STRING { sL1 $1 (noAnn,[stringLiteralToHsDocWst (L (gl $1) (getStringLiteral $1))]) } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -27,9 +27,9 @@ module GHC.Parser.Annotation ( EpAnnCO, -- ** Annotations in 'GenLocated' - LocatedA, LocatedN, LocatedAn, LocatedP, + LocatedA, LocatedN, LocatedAn, LocatedE, LocatedBF, - SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN, + SrcSpanAnnA, SrcSpanAnnN, SrcSpanAnnBF, -- ** Annotation data types used in 'GenLocated' @@ -430,7 +430,6 @@ emptyComments = EpaComments [] type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN -type LocatedP = GenLocated SrcSpanAnnP type LocatedBF = GenLocated SrcSpanAnnBF -- | Annotation for items appearing in a list. They can have one or @@ -441,7 +440,6 @@ type SrcSpanAnnA = EpAnn [TrailingAnn] -- on the context, such as backticks. type SrcSpanAnnN = EpAnn NameAnn -type SrcSpanAnnP = EpAnn AnnPragma type SrcSpanAnnBF = EpAnn AnnBooleanFormula type LocatedE = GenLocated EpaLocation ===================================== compiler/GHC/Unit/Module/Warnings.hs ===================================== @@ -158,8 +158,8 @@ warningTxtSame w1 w2 instance Outputable (InWarningCategory (GhcPass pass)) where ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt) -type instance XDeprecatedTxt (GhcPass _) = SourceText -type instance XWarningTxt (GhcPass _) = SourceText +type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnPragma) +type instance XWarningTxt (GhcPass _) = (SourceText, AnnPragma) type instance XXWarningTxt (GhcPass _) = DataConCantHappen type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) type instance XXInWarningCategory (GhcPass _) = DataConCantHappen @@ -167,7 +167,7 @@ type instance XXInWarningCategory (GhcPass _) = DataConCantHappen type instance Anno (WithHsDocIdentifiers (StringLiteral pass) pass) = SrcSpanAnnA type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation type instance Anno (WarningCategory) = EpaLocation -type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP +type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnA deriving stock instance Eq (WarningTxt GhcPs) deriving stock instance Eq (WarningTxt GhcRn) @@ -190,15 +190,15 @@ deriving instance Outputable WarningCategory instance Outputable (WarningTxt (GhcPass pass)) where ppr (WarningTxt lsrc mcat ws) = case lsrc of - NoSourceText -> pp_ws ws - SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" + (NoSourceText, _) -> pp_ws ws + (SourceText src, _) -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" where ctg_doc = maybe empty (\ctg -> ppr ctg) mcat ppr (DeprecatedTxt lsrc ds) = case lsrc of - NoSourceText -> pp_ws ds - SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" + (NoSourceText, _) -> pp_ws ds + (SourceText src, _) -> ftext src <+> pp_ws ds <+> text "#-}" pp_ws :: [LocatedA (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))] -> SDoc pp_ws [l] = ppr $ unLoc l ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1555,26 +1555,26 @@ instance ExactPrint ModuleName where -- --------------------------------------------------------------------- -instance ExactPrint (LocatedP (WarningTxt GhcPs)) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance ExactPrint (WarningTxt GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt src mb_cat ws)) = do + exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do o' <- markAnnOpen'' o src "{-# WARNING" mb_cat' <- markAnnotated mb_cat os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws')) + return (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws') - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do + exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do o' <- markAnnOpen'' o src "{-# DEPRECATED" os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws')) + return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws') instance ExactPrint (InWarningCategory GhcPs) where getAnnotationEntry _ = NoEntryVal View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b14d8d59d50527c8b396a3b768d6b92d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b14d8d59d50527c8b396a3b768d6b92d... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help