Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: be69e9df by Alan Zimmerman at 2026-08-06T15:53:05-04:00 EPA: Replace AnnPragma with individual types We introduced AnnPragma as a common type for all pragma usages wrapped in LocatedP / SrcSpanAnnP. Now that those are gone, and the AnnPragma moved into the TTG points for the given items, we can ensure that each carries only the annotations it needs. So we remove AnnPragma, and in its place bring in AnnCType AnnWarningTxt AnnOverlap AnnAnnDecl AnnPragSCC - - - - - 9 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Decls/Overlap.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Unit/Module/Warnings.hs - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1528,7 +1528,7 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XHsAnnotation (GhcPass _) = (AnnPragma, SourceText) +type instance XHsAnnotation (GhcPass _) = (AnnAnnDecl, SourceText) type instance XXAnnDecl (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where ===================================== compiler/GHC/Hs/Decls/Overlap.hs ===================================== @@ -26,7 +26,7 @@ import GHC.Prelude import GHC.Hs.Extension -import GHC.Parser.Annotation ( AnnPragma ) +import GHC.Parser.Annotation ( AnnOverlap ) import Language.Haskell.Syntax.Decls.Overlap import Language.Haskell.Syntax.Extension @@ -67,8 +67,8 @@ instance NFData OverlapFlag where instance Outputable OverlapFlag where ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) -type instance XOverlapMode GhcPs = (SourceText, AnnPragma) -type instance XOverlapMode GhcRn = (SourceText, AnnPragma) +type instance XOverlapMode GhcPs = (SourceText, AnnOverlap) +type instance XOverlapMode GhcRn = (SourceText, AnnOverlap) type instance XOverlapMode GhcTc = SourceText type instance XXOverlapMode (GhcPass _) = DataConCantHappen ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -612,7 +612,7 @@ instance NoAnn AnnFunRhs where -- --------------------------------------------------------------------- -type instance XSCC (GhcPass _) = (AnnPragma, SourceText) +type instance XSCC (GhcPass _) = (AnnPragSCC, SourceText) type instance XXPragE (GhcPass _) = DataConCantHappen type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel ===================================== compiler/GHC/Parser.y ===================================== @@ -1473,13 +1473,13 @@ inst_decl :: { LInstDecl GhcPs } overlap_pragma :: { Maybe (LocatedA (OverlapMode GhcPs)) } : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1, - AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + AnnOverlap (glR $1) (epTok $2)))) } | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1, - AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + AnnOverlap (glR $1) (epTok $2)))) } | '{-# OVERLAPS' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1, - AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + AnnOverlap (glR $1) (epTok $2)))) } | '{-# INCOHERENT' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1, - AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + AnnOverlap (glR $1) (epTok $2)))) } | {- empty -} { Nothing } deriv_strategy_no_via :: { LDerivStrategy GhcPs } @@ -1710,13 +1710,13 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs capi_ctype :: { Maybe (LocatedA (CType GhcPs)) } capi_ctype : '{-# CTYPE' STRING STRING '#-}' {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) - (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) + (AnnCType (glR $1) (epTok $4) (glR $2) (glR $3)) (Just (Header (getSTRINGs $2) (getSTRING $2))) (getSTRING $3)))} | '{-# CTYPE' STRING '#-}' {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) - (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) + (AnnCType (glR $1) (epTok $3) noAnn (glR $2)) Nothing (getSTRING $2)))} | { Nothing } @@ -2078,11 +2078,11 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } : '{-# DEPRECATED' strings '#-}' {% fmap Just $ amsA' (sLL $1 $> $ - DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) + DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnWarningTxt (glR $1) (epTok $3) (fst $ unLoc $2)) (snd $ unLoc $2))} | '{-# WARNING' warning_category strings '#-}' {% fmap Just $ amsA' (sLL $1 $> $ - WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn) + WarningTxt (getWARNING_PRAGs $1, AnnWarningTxt (glR $1) (epTok $4) (fst $ unLoc $3)) $2 (snd $ unLoc $3))} | {- empty -} { Nothing } @@ -2165,19 +2165,19 @@ stringlist :: { Located (OrdList (LocatedA (WithHsDocIdentifiers (StringLiteral annotation :: { LHsDecl GhcPs } : '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation - (AnnPragma (glR $1) (epTok $4) noAnn noAnn noAnn noAnn noAnn, + (AnnAnnDecl (glR $1) (epTok $4) noAnn noAnn, (getANN_PRAGs $1)) (ValueAnnProvenance $2) $3)) } | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 -> amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation - (AnnPragma (glR $1) (epTok $5) noAnn noAnn noAnn (epTok $2) noAnn, + (AnnAnnDecl (glR $1) (epTok $5) (epTok $2) noAnn, (getANN_PRAGs $1)) (TypeAnnProvenance $3) $4)) } | '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation - (AnnPragma (glR $1) (epTok $4) noAnn noAnn noAnn noAnn (epTok $2), + (AnnAnnDecl (glR $1) (epTok $4) noAnn (epTok $2), (getANN_PRAGs $1)) ModuleAnnProvenance $3)) } @@ -3052,12 +3052,12 @@ prag_e :: { Located (HsPragE GhcPs) } : '{-# SCC' STRING '#-}' {% do { scc <- getSCC $2 ; return (sLL $1 $> (HsPragSCC - (AnnPragma (glR $1) (epTok $3) noAnn (glR $2) noAnn noAnn noAnn, + (AnnPragSCC (glR $1) (epTok $3) (glR $2), (getSCC_PRAGs $1)) (StringLiteral (getSTRINGs $2) scc)))} } | '{-# SCC' VARID '#-}' { sLL $1 $> (HsPragSCC - (AnnPragma (glR $1) (epTok $3) noAnn (glR $2) noAnn noAnn noAnn, + (AnnPragSCC (glR $1) (epTok $3) (glR $2), (getSCC_PRAGs $1)) (StringLiteral NoSourceText (fastStringToShortText $ getVARID $2))) } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -36,7 +36,7 @@ module GHC.Parser.Annotation ( AnnList(..), AnnListBrackets(..), AnnParen(..), - AnnPragma(..), + AnnCType(..),AnnWarningTxt(..),AnnOverlap(..),AnnAnnDecl(..),AnnPragSCC(..), AnnBooleanFormula(..), NameAnn(..), NameAdornment(..), NoEpAnns(..), @@ -627,15 +627,40 @@ data NameAdornment -- | exact print annotation used for capturing the locations of -- annotations in pragmas. -data AnnPragma - = AnnPragma { - apr_open :: EpaLocation, - apr_close :: EpToken "#-}", - apr_squares :: (EpToken "[", EpToken "]"), - apr_loc1 :: EpaLocation, - apr_loc2 :: EpaLocation, - apr_type :: EpToken "type", - apr_module :: EpToken "module" +data AnnCType + = AnnCType { + ac_open :: EpaLocation, + ac_close :: EpToken "#-}", + ac_loc1 :: EpaLocation, + ac_loc2 :: EpaLocation + } deriving (Data,Eq) + +data AnnWarningTxt + = AnnWarningTxt { + awt_open :: EpaLocation, + awt_close :: EpToken "#-}", + awt_squares :: (EpToken "[", EpToken "]") + } deriving (Data,Eq) + +data AnnOverlap + = AnnOverlap { + ao_open :: EpaLocation, + ao_close :: EpToken "#-}" + } deriving (Data,Eq) + +data AnnAnnDecl + = AnnAnnDecl { + ad_open :: EpaLocation, + ad_close :: EpToken "#-}", + ad_type :: EpToken "type", + ad_module :: EpToken "module" + } deriving (Data,Eq) + +data AnnPragSCC + = AnnPragSCC { + aps_open :: EpaLocation, + aps_close :: EpToken "#-}", + aps_loc1 :: EpaLocation } deriving (Data,Eq) -- --------------------------------------------------------------------- @@ -1020,8 +1045,20 @@ instance NoAnn a => NoAnn (AnnList a) where instance NoAnn NameAnn where noAnn = NameAnnTrailing [] -instance NoAnn AnnPragma where - noAnn = AnnPragma noAnn noAnn noAnn noAnn noAnn noAnn noAnn +instance NoAnn AnnCType where + noAnn = AnnCType noAnn noAnn noAnn noAnn + +instance NoAnn AnnWarningTxt where + noAnn = AnnWarningTxt noAnn noAnn noAnn + +instance NoAnn AnnOverlap where + noAnn = AnnOverlap noAnn noAnn + +instance NoAnn AnnAnnDecl where + noAnn = AnnAnnDecl noAnn noAnn noAnn noAnn + +instance NoAnn AnnPragSCC where + noAnn = AnnPragSCC noAnn noAnn noAnn instance NoAnn AnnParen where noAnn = AnnParens noAnn noAnn @@ -1107,7 +1144,23 @@ instance Outputable AnnListBrackets where ppr (ListBanana o c) = text "ListBanana" <+> ppr o <+> ppr c ppr ListNone = text "ListNone" -instance Outputable AnnPragma where - ppr (AnnPragma o c s l ca t m) - = text "AnnPragma" <+> ppr o <+> ppr c <+> ppr s <+> ppr l - <+> ppr ca <+> ppr ca <+> ppr t <+> ppr m +instance Outputable AnnCType where + ppr (AnnCType o c l ca) + = text "AnnCType" <+> ppr o <+> ppr c <+> ppr l + <+> ppr ca <+> ppr ca + +instance Outputable AnnWarningTxt where + ppr (AnnWarningTxt o c s) + = text "AnnWarningTxt" <+> ppr o <+> ppr c <+> ppr s + +instance Outputable AnnOverlap where + ppr (AnnOverlap o c) + = text "AnnOverlap" <+> ppr o <+> ppr c + +instance Outputable AnnAnnDecl where + ppr (AnnAnnDecl o c t m) + = text "AnnAnnDecl" <+> ppr o <+> ppr c <+> ppr t <+> ppr m + +instance Outputable AnnPragSCC where + ppr (AnnPragSCC o c l) + = text "AnnPragSCC" <+> ppr o <+> ppr c <+> ppr l ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -109,7 +109,7 @@ import Data.Data (Data) import Data.Functor ((<&>)) import Control.DeepSeq (NFData(..)) -import GHC.Parser.Annotation (AnnPragma, noAnn) +import GHC.Parser.Annotation (AnnCType, noAnn) {- ************************************************************************ @@ -216,7 +216,7 @@ defaultCType :: String -> CType (GhcPass p) defaultCType = CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . packHText -mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p) +mkCType :: SourceText -> SourceText -> AnnCType -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p) mkCType x y ann m = CType (CTypeGhc x y ann) m @@ -303,7 +303,7 @@ data StaticTargetGhc = StaticTargetGhc data CTypeGhc = CTypeGhc { cTypeSourceText :: SourceText , cTypeOtherText :: SourceText - , cTypeAnn :: AnnPragma + , cTypeAnn :: AnnCType } deriving (Data, Eq) ===================================== 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, AnnPragma) -type instance XWarningTxt (GhcPass _) = (SourceText, AnnPragma) +type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnWarningTxt) +type instance XWarningTxt (GhcPass _) = (SourceText, AnnWarningTxt) type instance XXWarningTxt (GhcPass _) = DataConCantHappen type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) type instance XXInWarningCategory (GhcPass _) = DataConCantHappen ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -288,10 +288,6 @@ instance HasTrailing [TrailingAnn] where trailing a = a setTrailing _ ts = ts -instance HasTrailing AnnPragma where - trailing _ = [] - setTrailing a _ = a - instance HasTrailing AnnParen where trailing _ = [] setTrailing a _ = a @@ -1559,22 +1555,22 @@ instance ExactPrint (WarningTxt GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do + exact (WarningTxt (src, AnnWarningTxt o c (os,cs)) 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 (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws') + return (WarningTxt (src, AnnWarningTxt o' c' (os',cs')) mb_cat' ws') - exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do + exact (DeprecatedTxt (src, AnnWarningTxt o c (os,cs)) ws) = do o' <- markAnnOpen'' o src "{-# DEPRECATED" os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws') + return (DeprecatedTxt (src, AnnWarningTxt o' c' (os',cs')) ws') instance ExactPrint (InWarningCategory GhcPs) where getAnnotationEntry _ = NoEntryVal @@ -2251,35 +2247,35 @@ instance ExactPrint (OverlapMode GhcPs) where setAnnotationAnchor a _ _ _ = a -- NOTE: NoOverlap is only used in the typechecker - exact (NoOverlap (src, AnnPragma o c s l1 l2 t m)) = do + exact (NoOverlap (src, AnnOverlap o c)) = do o' <- markAnnOpen'' o src "{-# NO_OVERLAP" c' <- markEpToken c - return (NoOverlap (src, AnnPragma o' c' s l1 l2 t m)) + return (NoOverlap (src, AnnOverlap o' c')) - exact (Overlappable (src, AnnPragma o c s l1 l2 t m)) = do + exact (Overlappable (src, AnnOverlap o c)) = do o' <- markAnnOpen'' o src "{-# OVERLAPPABLE" c' <- markEpToken c - return (Overlappable (src, AnnPragma o' c' s l1 l2 t m)) + return (Overlappable (src, AnnOverlap o' c')) - exact (Overlapping (src, AnnPragma o c s l1 l2 t m)) = do + exact (Overlapping (src, AnnOverlap o c)) = do o' <- markAnnOpen'' o src "{-# OVERLAPPING" c' <- markEpToken c - return (Overlapping (src, AnnPragma o' c' s l1 l2 t m)) + return (Overlapping (src, AnnOverlap o' c')) - exact (Overlaps (src, AnnPragma o c s l1 l2 t m)) = do + exact (Overlaps (src, AnnOverlap o c)) = do o' <- markAnnOpen'' o src "{-# OVERLAPS" c' <- markEpToken c - return (Overlaps (src, AnnPragma o' c' s l1 l2 t m)) + return (Overlaps (src, AnnOverlap o' c')) - exact (Incoherent (src, AnnPragma o c s l1 l2 t m)) = do + exact (Incoherent (src, AnnOverlap o c)) = do o' <- markAnnOpen'' o src "{-# INCOHERENT" c' <- markEpToken c - return (Incoherent (src, AnnPragma o' c' s l1 l2 t m)) + return (Incoherent (src, AnnOverlap o' c')) - exact (NonCanonical (src, AnnPragma o c s l1 l2 t m)) = do + exact (NonCanonical (src, AnnOverlap o c)) = do o' <- markAnnOpen'' o src "{-# INCOHERENT" c' <- markEpToken c - return (Incoherent (src, AnnPragma o' c' s l1 l2 t m)) + return (Incoherent (src, AnnOverlap o' c')) -- --------------------------------------------------------------------- @@ -2706,7 +2702,7 @@ instance ExactPrint (AnnDecl GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (HsAnnotation (AnnPragma o c s l1 l2 t m, src) prov e) = do + exact (HsAnnotation (AnnAnnDecl o c t m, src) prov e) = do o' <- markAnnOpen'' o src "{-# ANN" (t', m', prov') <- case prov of @@ -2723,7 +2719,7 @@ instance ExactPrint (AnnDecl GhcPs) where e' <- markAnnotated e c' <- markEpToken c - return (HsAnnotation (AnnPragma o' c' s l1 l2 t' m',src) prov' e') + return (HsAnnotation (AnnAnnDecl o' c' t' m',src) prov' e') -- --------------------------------------------------------------------- @@ -3146,11 +3142,11 @@ instance ExactPrint (HsPragE GhcPs) where getAnnotationEntry HsPragSCC{} = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (HsPragSCC (AnnPragma o c s l1 l2 t m,st) sl) = do + exact (HsPragSCC (AnnPragSCC o c l1,st) sl) = do o' <- markAnnOpen'' o st "{-# SCC" l1' <- printStringAtAA l1 (sourceTextToString (stringLitSourceText sl) (unpackHText $ sl_fs sl)) c' <- markEpToken c - return (HsPragSCC (AnnPragma o' c' s l1' l2 t m,st) sl) + return (HsPragSCC (AnnPragSCC o' c' l1',st) sl) instance ExactPrint (HsTypedSplice GhcPs) where getAnnotationEntry _ = NoEntryVal @@ -4408,7 +4404,7 @@ instance Typeable p => ExactPrint (CType (GhcPass p)) where exact (CType ext mh ct) = do let stp = cTypeSourceText ext stct = cTypeOtherText ext - AnnPragma o c s l1 l2 t m = cTypeAnn ext + AnnCType o c l1 l2 = cTypeAnn ext o' <- markAnnOpen'' o stp "{-# CTYPE" l1' <- case mh of Nothing -> return l1 @@ -4416,7 +4412,7 @@ instance Typeable p => ExactPrint (CType (GhcPass p)) where printStringAtAA l1 (toSourceTextWithSuffix srcH "" "") l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackHText ct) "") c' <- markEpToken c - return (CType (ext { cTypeAnn = AnnPragma o' c' s l1' l2' t m }) mh ct) + return (CType (ext { cTypeAnn = AnnCType o' c' l1' l2' }) mh ct) -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -838,7 +838,7 @@ type instance Anno (HsSigType DocNameI) = SrcSpanAnnA type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA type instance Anno (CType DocNameI) = SrcSpanAnnA -type instance Anno (Header DocNameI) = EpAnn AnnPragma +type instance Anno (Header DocNameI) = SrcSpanAnnA type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be69e9dfc4bf2c2256c1c70af1e30cd7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be69e9dfc4bf2c2256c1c70af1e30cd7... 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