[Git][ghc/ghc][master] EPA: Use EpaLocation not SrcSpan in ForeignDecls
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Apr 5 01:31:28 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
1324b862 by Alan Zimmerman at 2024-04-04T21:30:44-04:00
EPA: Use EpaLocation not SrcSpan in ForeignDecls
This allows us to update them for makeDeltaAst in ghc-exactprint
- - - - -
7 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Ext/Utils.hs
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/ThToHs.hs
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1131,10 +1131,10 @@ type instance XForeignExport GhcTc = Coercion
type instance XXForeignDecl (GhcPass _) = DataConCantHappen
-type instance XCImport (GhcPass _) = Located SourceText -- original source text for the C entity
+type instance XCImport (GhcPass _) = LocatedE SourceText -- original source text for the C entity
type instance XXForeignImport (GhcPass _) = DataConCantHappen
-type instance XCExport (GhcPass _) = Located SourceText -- original source text for the C entity
+type instance XCExport (GhcPass _) = LocatedE SourceText -- original source text for the C entity
type instance XXForeignExport (GhcPass _) = DataConCantHappen
-- pretty printing of foreign declarations
@@ -1399,6 +1399,6 @@ type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (Maybe Role) = EpAnnCO
-type instance Anno CCallConv = SrcSpan
-type instance Anno Safety = SrcSpan
-type instance Anno CExportSpec = SrcSpan
+type instance Anno CCallConv = EpaLocation
+type instance Anno Safety = EpaLocation
+type instance Anno CExportSpec = EpaLocation
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -2095,15 +2095,15 @@ instance ToHie (LocatedA (ForeignDecl GhcRn)) where
instance ToHie (ForeignImport GhcRn) where
toHie (CImport (L c _) (L a _) (L b _) _ _) = concatM $
- [ locOnly a
- , locOnly b
- , locOnly c
+ [ locOnlyE a
+ , locOnlyE b
+ , locOnlyE c
]
instance ToHie (ForeignExport GhcRn) where
toHie (CExport (L b _) (L a _)) = concatM $
- [ locOnly a
- , locOnly b
+ [ locOnlyE a
+ , locOnlyE b
]
instance ToHie (LocatedA (WarnDecls GhcRn)) where
=====================================
compiler/GHC/Iface/Ext/Utils.hs
=====================================
@@ -533,6 +533,10 @@ locOnly (RealSrcSpan span _) = do
pure [Node e span []]
locOnly _ = pure []
+locOnlyE :: Monad m => EpaLocation -> ReaderT NodeOrigin m [HieAST a]
+locOnlyE (EpaSpan s) = locOnly s
+locOnlyE _ = pure []
+
mkScope :: (HasLoc a) => a -> Scope
mkScope a = case getHasLoc a of
(RealSrcSpan sp _) -> LocalScope sp
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -39,6 +39,7 @@ module GHC.Parser.Annotation (
-- ** Annotations in 'GenLocated'
LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP,
SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN,
+ LocatedE,
-- ** Annotation data types used in 'GenLocated'
@@ -644,6 +645,8 @@ type SrcSpanAnnL = EpAnn AnnList
type SrcSpanAnnP = EpAnn AnnPragma
type SrcSpanAnnC = EpAnn AnnContext
+type LocatedE = GenLocated EpaLocation
+
-- | General representation of a 'GenLocated' type carrying a
-- parameterised annotation type.
type LocatedAn an = GenLocated (EpAnn an)
@@ -1049,9 +1052,12 @@ reLoc (L la a) = L (noAnnSrcSpan $ locA (L la a) ) a
class HasAnnotation e where
noAnnSrcSpan :: SrcSpan -> e
-instance HasAnnotation (SrcSpan) where
+instance HasAnnotation SrcSpan where
noAnnSrcSpan l = l
+instance HasAnnotation EpaLocation where
+ noAnnSrcSpan l = EpaSpan l
+
instance (NoAnn ann) => HasAnnotation (EpAnn ann) where
noAnnSrcSpan l = EpAnn (spanAsAnchor l) noAnn emptyComments
@@ -1452,6 +1458,10 @@ instance (Outputable a, OutputableBndr e)
pprInfixOcc = pprInfixOcc . unLoc
pprPrefixOcc = pprPrefixOcc . unLoc
+instance (Outputable e)
+ => Outputable (GenLocated EpaLocation e) where
+ ppr = pprLocated
+
instance Outputable ParenType where
ppr t = text (show t)
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -2766,7 +2766,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
-- name (cf section 8.5.1 in Haskell 2010 report).
mkCImport = do
let e = unpackFS entity
- case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
+ case parseCImport (reLoc cconv) (reLoc safety) (mkExtName (unLoc v)) e (L loc esrc) of
Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $
PsErrMalformedEntityString
Just importSpec -> return importSpec
@@ -2782,7 +2782,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
then mkExtName (unLoc v)
else entity
funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
- importSpec = CImport (L loc esrc) cconv safety Nothing funcTarget
+ importSpec = CImport (L (l2l loc) esrc) (reLoc cconv) (reLoc safety) Nothing funcTarget
returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport
{ fd_i_ext = ann
@@ -2796,7 +2796,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
-- the string "foo" is ambiguous: either a header or a C identifier. The
-- C identifier case comes first in the alternatives below, so we pick
-- that one.
-parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
+parseCImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String
-> Located SourceText
-> Maybe (ForeignImport (GhcPass p))
parseCImport cconv safety nm str sourceText =
@@ -2826,7 +2826,7 @@ parseCImport cconv safety nm str sourceText =
| id_char c -> pfail
_ -> return ()
- mk h n = CImport sourceText cconv safety h n
+ mk h n = CImport (reLoc sourceText) (reLoc cconv) (reLoc safety) h n
hdr_char c = not (isSpace c)
-- header files are filenames, which can contain
@@ -2861,7 +2861,7 @@ mkExport :: Located CCallConv
mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)
= return $ \ann -> ForD noExtField $
ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty
- , fd_fe = CExport (L le esrc) (L lc (CExportStatic esrc entity' cconv)) }
+ , fd_fe = CExport (L (l2l le) esrc) (L (l2l lc) (CExportStatic esrc entity' cconv)) }
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -799,7 +799,8 @@ cvt_fundep (TH.FunDep xs ys) = do { xs' <- mapM tNameN xs
cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD (ImportF callconv safety from nm ty) =
- do { l <- getL
+ do { ls <- getL
+ ; let l = l2l ls
; if -- the prim and javascript calling conventions do not support headers
-- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess
| callconv == TH.Prim || callconv == TH.JavaScript
@@ -809,7 +810,7 @@ cvtForD (ImportF callconv safety from nm ty) =
True)))
| Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety')
(mkFastString (TH.nameBase nm))
- from (L l $ quotedSourceText from)
+ from (L ls $ quotedSourceText from)
-> mk_imp impspec
| otherwise
-> failWith $ InvalidCCallImpent from }
@@ -831,7 +832,8 @@ cvtForD (ImportF callconv safety from nm ty) =
cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
- ; l <- getL
+ ; ls <- getL
+ ; let l = l2l ls
; let astxt = mkFastString as
; let e = CExport (L l (SourceText astxt)) (L l (CExportStatic (SourceText astxt)
astxt
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -738,9 +738,9 @@ printStringAtAAC capture (EpaDelta d cs) s = do
-- ---------------------------------------------------------------------
-markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m ()
-markExternalSourceText l NoSourceText txt = printStringAtRs (realSrcSpan l) txt >> return ()
-markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) (unpackFS txt) >> return ()
+markExternalSourceTextE :: (Monad m, Monoid w) => EpaLocation -> SourceText -> String -> EP w m EpaLocation
+markExternalSourceTextE l NoSourceText txt = printStringAtAA l txt
+markExternalSourceTextE l (SourceText txt) _ = printStringAtAA l (unpackFS txt)
-- ---------------------------------------------------------------------
@@ -1587,6 +1587,15 @@ instance (ExactPrint a) => ExactPrint (Located a) where
exact (L l a) = L l <$> markAnnotated a
+instance (ExactPrint a) => ExactPrint (LocatedE a) where
+ getAnnotationEntry (L l _) = Entry l [] emptyComments NoFlushComments CanUpdateAnchorOnly
+ setAnnotationAnchor (L _ a) anc _ts _cs = L anc a
+
+ exact (L la a) = do
+ debugM $ "LocatedE a:la loc=" ++ show (ss2range $ locA la)
+ a' <- markAnnotated a
+ return (L la a')
+
instance (ExactPrint a) => ExactPrint (LocatedA a) where
getAnnotationEntry = entryFromLocatedA
setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs
@@ -2009,11 +2018,15 @@ instance ExactPrint (ForeignDecl GhcPs) where
instance ExactPrint (ForeignImport GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (CImport (L ls src) cconv safety@(L ll _) mh imp) = do
+ exact (CImport (L ls src) cconv safety@(L l _) mh imp) = do
cconv' <- markAnnotated cconv
- unless (ll == noSrcSpan) $ markAnnotated safety >> return ()
- unless (ls == noSrcSpan) $ markExternalSourceText ls src "" >> return ()
- return (CImport (L ls src) cconv' safety mh imp)
+ safety' <- if notDodgyE l
+ then markAnnotated safety
+ else return safety
+ ls' <- if notDodgyE ls
+ then markExternalSourceTextE ls src ""
+ else return ls
+ return (CImport (L ls' src) cconv' safety' mh imp)
-- ---------------------------------------------------------------------
@@ -2023,8 +2036,10 @@ instance ExactPrint (ForeignExport GhcPs) where
exact (CExport (L ls src) spec) = do
debugM $ "CExport starting"
spec' <- markAnnotated spec
- unless (ls == noSrcSpan) $ markExternalSourceText ls src ""
- return (CExport (L ls src) spec')
+ ls' <- if notDodgyE ls
+ then markExternalSourceTextE ls src ""
+ else return ls
+ return (CExport (L ls' src) spec')
-- ---------------------------------------------------------------------
@@ -3240,6 +3255,12 @@ markMaybeDodgyStmts an stmts =
return (an, r)
else return (an, stmts)
+notDodgyE :: EpaLocation -> Bool
+notDodgyE anc =
+ case anc of
+ EpaSpan s -> isGoodSrcSpan s
+ EpaDelta{} -> True
+
-- ---------------------------------------------------------------------
instance ExactPrint (HsPragE GhcPs) where
getAnnotationEntry HsPragSCC{} = NoEntryVal
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1324b8626aeb4dc2d6a04f7605d307ef13d1e0e9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1324b8626aeb4dc2d6a04f7605d307ef13d1e0e9
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240404/abf85b1a/attachment-0001.html>
More information about the ghc-commits
mailing list