From 723bc3523227ad505c92e16f11270bf9b524f4da Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Mon, 23 Oct 2023 20:17:57 +0100
Subject: [PATCH] EPA: print doc comments as normal comments
And ignore the ones allocated in haddock processing.
It does not guarantee that every original haddock-like comment appears
in the output, as it discards ones that have no legal attachment point.
closes #23459
---
compiler/GHC/Hs/DocString.hs | 1 +
utils/check-exact/ExactPrint.hs | 73 ++++++++++++++++++++++-----------
utils/check-exact/Preprocess.hs | 5 ++-
utils/check-exact/Utils.hs | 44 +++++++++++++++++++-
4 files changed, 95 insertions(+), 28 deletions(-)
diff --git a/compiler/GHC/Hs/DocString.hs b/compiler/GHC/Hs/DocString.hs
index 8e42c4a8d8a8..926c6a84dbcf 100644
--- a/compiler/GHC/Hs/DocString.hs
+++ b/compiler/GHC/Hs/DocString.hs
@@ -21,6 +21,7 @@ module GHC.Hs.DocString
, renderHsDocStrings
, exactPrintHsDocString
, pprWithDocString
+ , printDecorator
) where
import GHC.Prelude
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index ab47c954969d..d16f17af347b 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -32,6 +32,7 @@ module ExactPrint
) where
import GHC
+import GHC.Base (NonEmpty(..))
import GHC.Core.Coercion.Axiom (Role(..))
import GHC.Data.Bag
import qualified GHC.Data.BooleanFormula as BF
@@ -366,7 +367,7 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
when (flush == NoFlushComments) $ do
when ((getFollowingComments cs) /= []) $ do
debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)
- mapM_ printOneComment (map tokComment $ getFollowingComments cs)
+ mapM_ printOneComment (concatMap tokComment $ getFollowingComments cs)
debugM $ "ending trailing comments"
eof <- getEofPos
@@ -393,7 +394,7 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
-- ---------------------------------------------------------------------
addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m ()
-addCommentsA csNew = addComments (map tokComment csNew)
+addCommentsA csNew = addComments (concatMap tokComment csNew)
{-
TODO: When we addComments, some may have an anchor that is no longer
@@ -547,7 +548,7 @@ printStringAtAAC :: (Monad m, Monoid w)
=> CaptureComments -> EpaLocation -> String -> EP w m EpaLocation
printStringAtAAC capture (EpaSpan r _) s = printStringAtRsC capture r s
printStringAtAAC capture (EpaDelta d cs) s = do
- mapM_ (printOneComment . tokComment) cs
+ mapM_ printOneComment $ concatMap tokComment cs
pe1 <- getPriorEndD
p1 <- getPosP
printStringAtLsDelta d s
@@ -1357,7 +1358,7 @@ instance ExactPrint (HsModule GhcPs) where
exact hsmod@(HsModule {hsmodExt = XModulePs { hsmodAnn = EpAnnNotUsed }}) = withPpr hsmod >> return hsmod
exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do
- mbDoc' <- markAnnotated mbDoc
+ let mbDoc' = mbDoc
(an0, mmn' , mdeprec', mexports') <-
case mmn of
@@ -1382,7 +1383,7 @@ instance ExactPrint (HsModule GhcPs) where
am_decls' <- markTrailing (am_decls $ anns an0)
imports' <- markTopLevelList imports
- decls' <- markTopLevelList decls
+ decls' <- markTopLevelList (filter removeDocDecl decls)
lo1 <- case lo0 of
ExplicitBraces open close -> do
@@ -1402,6 +1403,11 @@ instance ExactPrint (HsModule GhcPs) where
return (HsModule (XModulePs anf lo1 mdeprec' mbDoc') mmn' mexports' imports' decls')
+
+removeDocDecl :: LHsDecl GhcPs -> Bool
+removeDocDecl (L _ DocD{}) = False
+removeDocDecl _ = True
+
-- ---------------------------------------------------------------------
instance ExactPrint ModuleName where
@@ -1533,9 +1539,27 @@ instance ExactPrint (ImportDecl GhcPs) where
instance ExactPrint HsDocString where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ = a
- exact ds = do
- (printStringAdvance . exactPrintHsDocString) ds
- return ds
+
+ exact (MultiLineDocString decorator (x :| xs)) = do
+ printStringAdvance ("-- " ++ printDecorator decorator)
+ pe <- getPriorEndD
+ debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x)
+ x' <- markAnnotated x
+ xs' <- markAnnotated (map dedentDocChunk xs)
+ return (MultiLineDocString decorator (x' :| xs'))
+ exact x = do
+ -- TODO: can this happen?
+ debugM $ "Not exact printing:" ++ showAst x
+ return x
+
+
+instance ExactPrint HsDocStringChunk where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ = a
+ exact chunk = do
+ printStringAdvance ("--" ++ unpackHDSC chunk)
+ return chunk
+
instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where
getAnnotationEntry _ = NoEntryVal
@@ -1895,11 +1919,8 @@ instance ExactPrint (DocDecl GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ = a
- exact v = case v of
- (DocCommentNext ds) -> DocCommentNext <$> exact ds
- (DocCommentPrev ds) -> DocCommentPrev <$> exact ds
- (DocCommentNamed s ds) -> DocCommentNamed s <$> exact ds
- (DocGroup i ds) -> DocGroup i <$> exact ds
+ -- We print these as plain comments instead, do a NOP here.
+ exact v = return v
-- ---------------------------------------------------------------------
@@ -3936,8 +3957,7 @@ instance ExactPrint (HsType GhcPs) where
return (HsSpliceTy a splice')
exact (HsDocTy an ty doc) = do
ty' <- markAnnotated ty
- doc' <- markAnnotated doc
- return (HsDocTy an ty' doc')
+ return (HsDocTy an ty' doc)
exact (HsBangTy an (HsSrcBang mt up str) ty) = do
an0 <-
case mt of
@@ -4246,7 +4266,6 @@ instance ExactPrint (ConDecl GhcPs) where
, con_mb_cxt = mcxt
, con_args = args
, con_doc = doc }) = do
- doc' <- mapM markAnnotated doc
an0 <- if has_forall
then markEpAnnL an lidl AnnForall
else return an
@@ -4266,11 +4285,11 @@ instance ExactPrint (ConDecl GhcPs) where
, con_ex_tvs = ex_tvs'
, con_mb_cxt = mcxt'
, con_args = args'
- , con_doc = doc' })
+ , con_doc = doc })
where
- -- -- In ppr_details: let's not print the multiplicities (they are always 1, by
- -- -- definition) as they do not appear in an actual declaration.
+ -- In ppr_details: let's not print the multiplicities (they are always 1, by
+ -- definition) as they do not appear in an actual declaration.
exact_details (InfixCon t1 t2) = do
t1' <- markAnnotated t1
con' <- markAnnotated con
@@ -4294,7 +4313,6 @@ instance ExactPrint (ConDecl GhcPs) where
, con_bndrs = bndrs
, con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty, con_doc = doc }) = do
- doc' <- mapM markAnnotated doc
cons' <- mapM markAnnotated cons
dcol' <- markUniToken dcol
an1 <- annotationsToComments an lidl [AnnOpenP, AnnCloseP]
@@ -4323,7 +4341,7 @@ instance ExactPrint (ConDecl GhcPs) where
, con_dcolon = dcol'
, con_bndrs = bndrs'
, con_mb_cxt = mcxt', con_g_args = args'
- , con_res_ty = res_ty', con_doc = doc' })
+ , con_res_ty = res_ty', con_doc = doc })
-- ---------------------------------------------------------------------
@@ -4359,8 +4377,8 @@ instance ExactPrint (ConDeclField GhcPs) where
names' <- markAnnotated names
an0 <- markEpAnnL an lidl AnnDcolon
ftype' <- markAnnotated ftype
- mdoc' <- mapM markAnnotated mdoc
- return (ConDeclField an0 names' ftype' mdoc')
+ -- mdoc' <- mapM markAnnotated mdoc
+ return (ConDeclField an0 names' ftype' mdoc)
-- ---------------------------------------------------------------------
@@ -4563,7 +4581,14 @@ instance ExactPrint (IE GhcPs) where
m' <- markAnnotated m
return (IEModuleContents (depr', an0) m')
- exact x = error $ "missing match for IE:" ++ showAst x
+ -- These three exist to not error out, but are no-ops The contents
+ -- appear as "normal" comments too, which we process instead.
+ exact (IEGroup x lev doc) = do
+ return (IEGroup x lev doc)
+ exact (IEDoc x doc) = do
+ return (IEDoc x doc)
+ exact (IEDocNamed x str) = do
+ return (IEDocNamed x str)
-- ---------------------------------------------------------------------
diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs
index 55d84763f51e..87df87b1c2ca 100644
--- a/utils/check-exact/Preprocess.hs
+++ b/utils/check-exact/Preprocess.hs
@@ -124,8 +124,9 @@ getCppTokensAsComments cppOptions sourceFile = do
goodComment :: GHC.LEpaComment -> Bool
goodComment c = isGoodComment (tokComment c)
where
- isGoodComment :: Comment -> Bool
- isGoodComment (Comment "" _ _ _) = False
+ isGoodComment :: [Comment] -> Bool
+ isGoodComment [] = False
+ isGoodComment [Comment "" _ _ _] = False
isGoodComment _ = True
diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs
index 404bfd4c7c55..6c22a939d7e8 100644
--- a/utils/check-exact/Utils.hs
+++ b/utils/check-exact/Utils.hs
@@ -36,6 +36,7 @@ import GHC.Types.SrcLoc
import GHC.Driver.Ppr
import GHC.Data.FastString
import qualified GHC.Data.Strict as Strict
+import GHC.Base (NonEmpty(..))
import Data.Data hiding ( Fixity )
import Data.List (sortBy, elemIndex)
@@ -236,8 +237,47 @@ ghcCommentText (L _ (GHC.EpaComment (EpaLineComment s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _)) = ""
-tokComment :: LEpaComment -> Comment
-tokComment t@(L lt c) = mkComment (normaliseCommentText $ ghcCommentText t) lt (ac_prior_tok c)
+tokComment :: LEpaComment -> [Comment]
+tokComment t@(L lt c) =
+ case c of
+ (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments lt pt dc
+ _ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)]
+
+hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment]
+hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) =
+ let
+ decStr = printDecorator dec
+ L lx x' = dedentDocChunkBy (3 + length decStr) x
+ str = "-- " ++ decStr ++ unpackHDSC x'
+ docChunk _ [] = []
+ docChunk pt' (L l chunk:cs)
+ = Comment ("--" ++ unpackHDSC chunk) (spanAsAnchor l) pt' Nothing : docChunk (rs l) cs
+ in
+ (Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs))
+hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk))
+ = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]
+hsDocStringComments anc pt (NestedDocString dec (L _ chunk))
+ = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]
+
+hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code
+
+-- At the moment the locations of the 'HsDocStringChunk's are from the start of
+-- the string part, leaving aside the "--". So we need to subtract 2 columns from it
+dedentDocChunk :: LHsDocStringChunk -> LHsDocStringChunk
+dedentDocChunk chunk = dedentDocChunkBy 2 chunk
+
+dedentDocChunkBy :: Int -> LHsDocStringChunk -> LHsDocStringChunk
+dedentDocChunkBy dedent (L (RealSrcSpan l mb) c) = L (RealSrcSpan l' mb) c
+ where
+ f = srcSpanFile l
+ sl = srcSpanStartLine l
+ sc = srcSpanStartCol l
+ el = srcSpanEndLine l
+ ec = srcSpanEndCol l
+ l' = mkRealSrcSpan (mkRealSrcLoc f sl (sc - dedent))
+ (mkRealSrcLoc f el (ec - dedent))
+
+dedentDocChunkBy _ x = x
mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments
mkEpaComments priorCs []
--
GitLab