Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC
Commits:
-
030cd0f1
by Alan Zimmerman at 2026-07-04T14:53:06+01:00
-
e05bcb77
by Alan Zimmerman at 2026-07-04T15:59:29+01:00
-
982953c9
by Alan Zimmerman at 2026-07-05T09:52:40+01:00
9 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Unit/Module/Warnings.hs
- utils/check-exact/ExactPrint.hs
Changes:
| ... | ... | @@ -1472,10 +1472,10 @@ type instance XForeignExport GhcTc = Coercion |
| 1472 | 1472 | |
| 1473 | 1473 | type instance XXForeignDecl (GhcPass _) = DataConCantHappen
|
| 1474 | 1474 | |
| 1475 | -type instance XCImport (GhcPass _) = LocatedE SourceText -- original source text for the C entity
|
|
| 1475 | +type instance XCImport (GhcPass _) = LocatedA SourceText -- original source text for the C entity
|
|
| 1476 | 1476 | type instance XXForeignImport (GhcPass _) = DataConCantHappen
|
| 1477 | 1477 | |
| 1478 | -type instance XCExport (GhcPass _) = LocatedE SourceText -- original source text for the C entity
|
|
| 1478 | +type instance XCExport (GhcPass _) = LocatedA SourceText -- original source text for the C entity
|
|
| 1479 | 1479 | type instance XXForeignExport (GhcPass _) = DataConCantHappen
|
| 1480 | 1480 | |
| 1481 | 1481 | |
| ... | ... | @@ -1729,6 +1729,6 @@ type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA |
| 1729 | 1729 | type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA
|
| 1730 | 1730 | type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA
|
| 1731 | 1731 | type instance Anno (Maybe Role) = EpAnnCO
|
| 1732 | -type instance Anno CCallConv = EpaLocation
|
|
| 1733 | -type instance Anno Safety = EpaLocation
|
|
| 1734 | -type instance Anno CExportSpec = EpaLocation |
|
| 1732 | +type instance Anno CCallConv = SrcSpanAnnA
|
|
| 1733 | +type instance Anno Safety = SrcSpanAnnA
|
|
| 1734 | +type instance Anno CExportSpec = SrcSpanAnnA |
| ... | ... | @@ -353,7 +353,7 @@ hsRecFieldId = hsRecFieldSel |
| 353 | 353 | ************************************************************************
|
| 354 | 354 | -}
|
| 355 | 355 | |
| 356 | -instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ LocatedE RecFieldsDotDot)
|
|
| 356 | +instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ LocatedA RecFieldsDotDot)
|
|
| 357 | 357 | => Outputable (HsRecFields p arg) where
|
| 358 | 358 | ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
|
| 359 | 359 | = braces (fsep (punctuate comma (map ppr flds)))
|
| ... | ... | @@ -1178,4 +1178,4 @@ type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA |
| 1178 | 1178 | type instance Anno (HsOverLit (GhcPass p)) = EpAnnCO
|
| 1179 | 1179 | type instance Anno ConLike = SrcSpanAnnN
|
| 1180 | 1180 | type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA
|
| 1181 | -type instance Anno RecFieldsDotDot = EpaLocation |
|
| 1181 | +type instance Anno RecFieldsDotDot = SrcSpanAnnA |
| ... | ... | @@ -2210,15 +2210,15 @@ instance ToHie (LocatedA (ForeignDecl GhcRn)) where |
| 2210 | 2210 | |
| 2211 | 2211 | instance ToHie (ForeignImport GhcRn) where
|
| 2212 | 2212 | toHie (CImport (L c _) (L a _) (L b _) _ _) = concatM $
|
| 2213 | - [ locOnlyE a
|
|
| 2214 | - , locOnlyE b
|
|
| 2215 | - , locOnlyE c
|
|
| 2213 | + [ locOnlyE (entry a)
|
|
| 2214 | + , locOnlyE (entry b)
|
|
| 2215 | + , locOnlyE (entry c)
|
|
| 2216 | 2216 | ]
|
| 2217 | 2217 | |
| 2218 | 2218 | instance ToHie (ForeignExport GhcRn) where
|
| 2219 | 2219 | toHie (CExport (L b _) (L a _)) = concatM $
|
| 2220 | - [ locOnlyE a
|
|
| 2221 | - , locOnlyE b
|
|
| 2220 | + [ locOnlyE (entry a)
|
|
| 2221 | + , locOnlyE (entry b)
|
|
| 2222 | 2222 | ]
|
| 2223 | 2223 | |
| 2224 | 2224 | instance ToHie (LocatedA (WarnDecls GhcRn)) where
|
| ... | ... | @@ -2084,7 +2084,7 @@ maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } |
| 2084 | 2084 | $2 (snd $ unLoc $3))}
|
| 2085 | 2085 | | {- empty -} { Nothing }
|
| 2086 | 2086 | |
| 2087 | -warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) }
|
|
| 2087 | +warning_category :: { Maybe (LocatedA (InWarningCategory GhcPs)) }
|
|
| 2088 | 2088 | : 'in' STRING { Just (reLoc $ sLL $1 $> $ InWarningCategory (epTok $1, getSTRINGs $2)
|
| 2089 | 2089 | (reLoc $ sL1 $2 $ mkWarningCategory (getSTRING $2))) }
|
| 2090 | 2090 | | {- empty -} { Nothing }
|
| ... | ... | @@ -3214,7 +3214,7 @@ mkImport cconv safety (L loc sLit, v, ty) (timport, td) = |
| 3214 | 3214 | -- the string "foo" is ambiguous: either a header or a C identifier. The
|
| 3215 | 3215 | -- C identifier case comes first in the alternatives below, so we pick
|
| 3216 | 3216 | -- that one.
|
| 3217 | -parseCImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String
|
|
| 3217 | +parseCImport :: LocatedA CCallConv -> LocatedA Safety -> FastString -> String
|
|
| 3218 | 3218 | -> Located SourceText
|
| 3219 | 3219 | -> Maybe (ForeignImport GhcPs)
|
| 3220 | 3220 | parseCImport cconv safety nm str sourceText =
|
| ... | ... | @@ -859,7 +859,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) |
| 859 | 859 | , hfbRHS = arg'
|
| 860 | 860 | , hfbPun = pun } }
|
| 861 | 861 | |
| 862 | - rn_dotdot :: Maybe (LocatedE RecFieldsDotDot) -- See Note [DotDot fields] in GHC.Hs.Pat
|
|
| 862 | + rn_dotdot :: Maybe (LocatedA RecFieldsDotDot) -- See Note [DotDot fields] in GHC.Hs.Pat
|
|
| 863 | 863 | -> Maybe (WithUserRdr Name)
|
| 864 | 864 | -- The constructor (Nothing for an out of scope constructor)
|
| 865 | 865 | -> [LHsRecField GhcRn (LocatedA arg)] -- Explicit fields
|
| ... | ... | @@ -72,7 +72,6 @@ import GHC.Rename.Utils( mkRnSyntaxExpr ) |
| 72 | 72 | import GHC.Types.Id.Make( mkDictFunId )
|
| 73 | 73 | import GHC.Types.Arity ( Arity, VisArity )
|
| 74 | 74 | import GHC.Types.Basic ( TypeOrKind(..) )
|
| 75 | -import GHC.Types.SourceText
|
|
| 76 | 75 | import GHC.Types.SrcLoc as SrcLoc
|
| 77 | 76 | import GHC.Types.Var.Env
|
| 78 | 77 | import GHC.Types.Id
|
| ... | ... | @@ -166,8 +166,8 @@ type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) |
| 166 | 166 | type instance XXInWarningCategory (GhcPass _) = DataConCantHappen
|
| 167 | 167 | |
| 168 | 168 | type instance Anno (WithHsDocIdentifiers (StringLiteral pass) pass) = SrcSpanAnnA
|
| 169 | -type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation
|
|
| 170 | -type instance Anno (WarningCategory) = EpaLocation
|
|
| 169 | +type instance Anno (InWarningCategory (GhcPass pass)) = SrcSpanAnnA
|
|
| 170 | +type instance Anno (WarningCategory) = SrcSpanAnnA
|
|
| 171 | 171 | type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnA
|
| 172 | 172 | |
| 173 | 173 | deriving stock instance Eq (WarningTxt GhcPs)
|
| ... | ... | @@ -726,6 +726,11 @@ printStringAtMLocL an l s = do |
| 726 | 726 | printStringAdvanceA :: (Monad m, Monoid w) => String -> EP w m ()
|
| 727 | 727 | printStringAdvanceA str = printStringAtAA (EpaDelta noSrcSpan (SameLine 0) []) str >> return ()
|
| 728 | 728 | |
| 729 | +printStringAtA :: (Monad m, Monoid w) => EpAnn a -> String -> EP w m (EpAnn a)
|
|
| 730 | +printStringAtA ann s = do
|
|
| 731 | + l' <- printStringAtAA (entry ann) s
|
|
| 732 | + return ann { entry = l' }
|
|
| 733 | + |
|
| 729 | 734 | printStringAtAA :: (Monad m, Monoid w) => EpaLocation -> String -> EP w m EpaLocation
|
| 730 | 735 | printStringAtAA el str = printStringAtAAC CaptureComments el str
|
| 731 | 736 | |
| ... | ... | @@ -750,9 +755,13 @@ printStringAtAAC capture (EpaDelta ss d cs) s = do |
| 750 | 755 | |
| 751 | 756 | -- ---------------------------------------------------------------------
|
| 752 | 757 | |
| 753 | -markExternalSourceTextE :: (Monad m, Monoid w) => EpaLocation -> SourceText -> String -> EP w m EpaLocation
|
|
| 754 | -markExternalSourceTextE l NoSourceText txt = printStringAtAA l txt
|
|
| 755 | -markExternalSourceTextE l (SourceText txt) _ = printStringAtAA l (unpackFS txt)
|
|
| 758 | +markExternalSourceTextA :: (Monad m, Monoid w) => EpAnn a -> SourceText -> String -> EP w m (EpAnn a)
|
|
| 759 | +markExternalSourceTextA ann src txt = do
|
|
| 760 | + l' <- mark_source_text ann src txt
|
|
| 761 | + return (ann { entry = l'})
|
|
| 762 | + where
|
|
| 763 | + mark_source_text l NoSourceText txt' = printStringAtAA (entry l) txt'
|
|
| 764 | + mark_source_text l (SourceText txt') _ = printStringAtAA (entry l) (unpackFS txt')
|
|
| 756 | 765 | |
| 757 | 766 | -- ---------------------------------------------------------------------
|
| 758 | 767 | |
| ... | ... | @@ -1868,11 +1877,11 @@ instance ExactPrint (ForeignImport GhcPs) where |
| 1868 | 1877 | setAnnotationAnchor a _ _ _ = a
|
| 1869 | 1878 | exact (CImport (L ls src) cconv safety@(L l _) mh imp) = do
|
| 1870 | 1879 | cconv' <- markAnnotated cconv
|
| 1871 | - safety' <- if notDodgyE l
|
|
| 1880 | + safety' <- if notDodgyE (entry l)
|
|
| 1872 | 1881 | then markAnnotated safety
|
| 1873 | 1882 | else return safety
|
| 1874 | - ls' <- if notDodgyE ls
|
|
| 1875 | - then markExternalSourceTextE ls src ""
|
|
| 1883 | + ls' <- if notDodgyE (entry ls)
|
|
| 1884 | + then markExternalSourceTextA ls src ""
|
|
| 1876 | 1885 | else return ls
|
| 1877 | 1886 | return (CImport (L ls' src) cconv' safety' mh imp)
|
| 1878 | 1887 | |
| ... | ... | @@ -1884,8 +1893,8 @@ instance ExactPrint (ForeignExport GhcPs) where |
| 1884 | 1893 | exact (CExport (L ls src) spec) = do
|
| 1885 | 1894 | debugM $ "CExport starting"
|
| 1886 | 1895 | spec' <- markAnnotated spec
|
| 1887 | - ls' <- if notDodgyE ls
|
|
| 1888 | - then markExternalSourceTextE ls src ""
|
|
| 1896 | + ls' <- if notDodgyE (entry ls)
|
|
| 1897 | + then markExternalSourceTextA ls src ""
|
|
| 1889 | 1898 | else return ls
|
| 1890 | 1899 | return (CExport (L ls' src) spec')
|
| 1891 | 1900 | |
| ... | ... | @@ -3215,7 +3224,7 @@ instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where |
| 3215 | 3224 | mdot' <- case mdot of
|
| 3216 | 3225 | Nothing -> return Nothing
|
| 3217 | 3226 | Just (L ss d) -> do
|
| 3218 | - ss' <- printStringAtAA ss ".."
|
|
| 3227 | + ss' <- printStringAtA ss ".."
|
|
| 3219 | 3228 | return $ Just (L ss' d)
|
| 3220 | 3229 | -- Note: mdot contains the SrcSpan where the ".." appears, if present
|
| 3221 | 3230 | cc' <- markEpToken cc
|