GitLab

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:

@@ -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