recursion-ninja pushed to branch wip/fix-26636 at Glasgow Haskell Compiler / GHC Commits: e8d13551 by Recursion Ninja at 2025-12-09T10:28:09-05:00 Reorganizing 'Warning' record extensibility - - - - - 5 changed files: - compiler/GHC/Rename/Module.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Unit/Module/Warnings.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Extension.hs Changes: ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -321,11 +321,13 @@ rnSrcWarnDecls bndr_set decls' rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn) rnWarningTxt (WarningTxt mb_cat st wst) = do - forM_ mb_cat $ \(L _ (InWarningCategory _ _ (L loc cat))) -> - unless (validWarningCategory cat) $ - addErrAt (locA loc) (TcRnInvalidWarningCategory cat) + mb_cat' <- forM mb_cat $ \(L x (InWarningCategory y z wCat@(L loc cat))) -> do + unless (validWarningCategory cat) $ + addErrAt (locA loc) (TcRnInvalidWarningCategory cat) + wCat' <- traverse rnHsDoc wCat + pure (L x (InWarningCategory y z wCat')) wst' <- traverse (traverse rnHsDoc) wst - pure (WarningTxt (mb_cat :: _) st wst') + pure (WarningTxt mb_cat' st wst') -- pure (WarningTxt mb_cat st wst') rnWarningTxt (DeprecatedTxt st wst) = do wst' <- traverse (traverse rnHsDoc) wst ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -767,6 +767,7 @@ type family GhcDiagnosticCode c = n | n -> c where -- TcRnPragmaWarning GhcDiagnosticCode "WarningTxt" = 63394 GhcDiagnosticCode "DeprecatedTxt" = 68441 + GhcDiagnosticCode "XWarningTxt" = 68077 -- TcRnRunSliceFailure/ConversionFail GhcDiagnosticCode "IllegalOccName" = 55017 ===================================== compiler/GHC/Unit/Module/Warnings.hs ===================================== @@ -130,7 +130,7 @@ data InWarningCategory fromWarningCategory :: (HasAnnotation (Anno (WarningCategory (GhcPass p)))) => WarningCategory (GhcPass p) -> InWarningCategory (GhcPass p) -fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc) +fromWarningCategory wc = InWarningCategory (noAnn, NoSourceText) (noLocA wc) {- -- See Note [Warning categories] @@ -142,10 +142,10 @@ mkWarningCategory :: FastString -> WarningCategory mkWarningCategory = WarningCategory -} -type instance XWarningTxt (GhcPass _) = SourceText type instance XDeprecatedTxt (GhcPass _) = SourceText -type instance XInWarningCategory (GhcPass _) = SourceText -type instance XInWarningCategoryIn (GhcPass _) = (EpToken "in") +type instance XWarningTxt (GhcPass _) = SourceText +type instance XXWarningTxt (GhcPass _) = DataConCantHappen +type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) type instance XWarningCategory (GhcPass _) = FastString type instance Anno (WithHsDocIdentifiers StringLiteral pass) = EpaLocation @@ -232,7 +232,7 @@ data WarningTxt pass -- | To which warning category does this WARNING or DEPRECATED pragma belong? -- See Note [Warning categories]. warningTxtCategory :: WarningTxt (GhcPass p) -> WarningCategory (GhcPass p) -warningTxtCategory (WarningTxt (Just (L _ (InWarningCategory _ _ (L _ cat)))) _ _) = cat +warningTxtCategory (WarningTxt (Just (L _ (InWarningCategory _ (L _ cat)))) _ _) = cat warningTxtCategory _ = defaultWarningCategory @@ -255,7 +255,7 @@ warningTxtSame w1 w2 | otherwise = False instance Outputable (XRec p (WarningCategory p)) => Outputable (InWarningCategory p) where - ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt) + ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt) deriving instance ( Binary (XWarningCategory p) ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -93,10 +93,10 @@ module Language.Haskell.Syntax.Decls ( mkWarningCategory, InWarningCategory(..), -- ** Extension - XWarningTxt, XDeprecatedTxt, + XWarningTxt, + XXWarningTxt, XInWarningCategory, - XInWarningCategoryIn, XWarningCategory ) where @@ -115,6 +115,7 @@ import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation ,TyConFlavour(..), TypeOrData(..), NewOrData(..)) import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) +import GHC.Data.FastString (FastString) import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST import GHC.Hs.Doc (WithHsDocIdentifiers) import GHC.Types.SourceText (StringLiteral) @@ -1608,6 +1609,13 @@ data RoleAnnotDecl pass [XRec pass (Maybe Role)] -- optional annotations | XRoleAnnotDecl !(XXRoleAnnotDecl pass) +{- +************************************************************************ +* * +\subsection[WarnAnnot]{Warning annotations} +* * +************************************************************************ +-} -- | Warning Text -- @@ -1626,54 +1634,35 @@ data WarningTxt pass deriving Generic -} -type family XWarningTxt p -type family XDeprecatedTxt p - data WarningTxt pass - = WarningTxt + = DeprecatedTxt + (XDeprecatedTxt pass) + [XRec pass (WithHsDocIdentifiers StringLiteral pass)] + | WarningTxt (Maybe (XRec pass (InWarningCategory pass))) -- ^ Warning category attached to this WARNING pragma, if any; -- see Note [Warning categories] (XWarningTxt pass) [XRec pass (WithHsDocIdentifiers StringLiteral pass)] - | DeprecatedTxt - (XDeprecatedTxt pass) - [XRec pass (WithHsDocIdentifiers StringLiteral pass)] + | XWarningTxt !(XXWarningTxt pass) deriving Generic -deriving stock instance ( - Eq (XWarningTxt pass), - Eq (XDeprecatedTxt pass), - Eq (XRec pass (InWarningCategory pass)), - Eq (XRec pass (WithHsDocIdentifiers StringLiteral pass)) - ) => Eq (WarningTxt pass) deriving stock instance ( Data pass, - Data (XWarningTxt pass), Data (XDeprecatedTxt pass), + Data (XWarningTxt pass), + Data (XXWarningTxt pass), Data (XRec pass (InWarningCategory pass)), Data (XRec pass (WithHsDocIdentifiers StringLiteral pass)) ) => Data (WarningTxt pass) -{- --- | The message that the WarningTxt was specified to output -warningTxtMessage :: WarningTxt p -> [LocatedE (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 stock instance ( + Eq (XDeprecatedTxt pass), + Eq (XWarningTxt pass), + Eq (XXWarningTxt pass), + Eq (XRec pass (InWarningCategory pass)), + Eq (XRec pass (WithHsDocIdentifiers StringLiteral pass)) + ) => Eq (WarningTxt pass) {- Note [Warning categories] @@ -1728,40 +1717,29 @@ data InWarningCategory iwc_wc :: (LocatedE WarningCategory) } deriving Data -} -type family XInWarningCategory p -type family XInWarningCategoryIn p data InWarningCategory pass = InWarningCategory - { iwc_in :: !(XInWarningCategoryIn pass), --- iwc_in :: !(EpToken "in"), - iwc_st :: (XInWarningCategory pass), - iwc_wc :: (XRec pass (WarningCategory pass)) + { iwc_st :: (XInWarningCategory pass), + iwc_wc :: (XRec pass WarningCategory) } + | XInWarningCategory pass deriving stock instance ( Data pass, Data (XInWarningCategory pass), - Data (XInWarningCategoryIn pass), - Data (XRec pass (WarningCategory pass)) + Data (XRec pass WarningCategory) ) => Data (InWarningCategory pass) -deriving instance ( +deriving stock instance ( +-- Eq p, -- Add this and then all the type family values complain about Eq instances. Eq (XInWarningCategory p), - Eq (XInWarningCategoryIn p), - Eq (XRec p (WarningCategory p)) + Eq (XRec p WarningCategory) ) => Eq (InWarningCategory p) -type family XWarningCategory p - --- See Note [Warning categories] -newtype WarningCategory pass = WarningCategory (XWarningCategory pass) - -- Must add back Binary, Outputable, Uniquable - -deriving stock instance (Data pass, Data (XWarningCategory pass)) => Data (WarningCategory pass) -deriving newtype instance Eq (XWarningCategory pass) => Eq (WarningCategory pass) -deriving newtype instance Show (XWarningCategory pass) => Show (WarningCategory pass) -deriving newtype instance NFData (XWarningCategory pass) => NFData (WarningCategory pass) +newtype WarningCategory = WarningCategory FastString + deriving stock (Data) + deriving newtype (Eq, Show, NFData) -mkWarningCategory :: XWarningCategory pass -> WarningCategory pass +mkWarningCategory :: FastString -> WarningCategory mkWarningCategory = WarningCategory ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -421,6 +421,21 @@ type family XXWarnDecls x type family XWarning x type family XXWarnDecl x +-- ------------------------------------- +-- WarningTxt type families +type family XDeprecatedTxt x +type family XWarningTxt x +type family XXWarningTxt x + +-- ------------------------------------- +-- InWarningCategory type families +type family XInWarningCategory x +type family XXInWarningCategory x + +-- ------------------------------------- +-- WarningCategory type family +type family XWarningCategory x + -- ------------------------------------- -- AnnDecl type families type family XHsAnnotation x View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8d1355174a1bac067b333365a338e9e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8d1355174a1bac067b333365a338e9e... You're receiving this email because of your account on gitlab.haskell.org.