Alan Zimmerman pushed to branch wip/az/epa-tidy-locatedxxx-20 at Glasgow Haskell Compiler / GHC Commits: e3675b4c by Alan Zimmerman at 2026-08-23T09:55:43+01:00 EPA: Uses Parsers.parseModule for exactprint tests Parsers.parseModule is the advertised way to parse for use for exact printing in the ghc-exactprint library. This commit updates the GHC exact print testing to use it. This requires moving the comment balancing that was occurring only in the test path into the advertising parser path, so it moves from Transforms.hs to Utils.hs. Also update the comment adding to honour trailing annotations - - - - - 5 changed files: - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs Changes: ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where Just exps -> do let (op,cp,tcs) = am_exports $ anns an0 op' <- markEpToken op - exps' <- mapM markAnnotated exps + exps' <- mapM markAnnotated (filter notIEDoc exps) tcs' <- mapM markEpToken tcs cp' <- markEpToken cp return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}}) ===================================== utils/check-exact/Main.hs ===================================== @@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Test17519.hs" Nothing -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing -- "../../testsuite/tests/printer/Test19798.hs" Nothing - "../../testsuite/tests/printer/Test10309.hs" Nothing + -- "../../testsuite/tests/printer/Test10309.hs" Nothing + "../../testsuite/tests/printer/Haddock1.hs" Nothing -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing @@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO () testOneFile _ libdir fileName mchanger = do - (p,_toks) <- parseOneFile libdir fileName + p <- parseOneFile libdir fileName let origAst = ppAst p pped = exactPrint p @@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do changedSource <- readFile newFile return (expectedSource == changedSource, expectedSource, changedSource) - (p',_) <- parseOneFile libdir newFile + p' <- parseOneFile libdir newFile let newAstStr :: String newAstStr = ppAst p' writeBinFile newAstFile newAstStr @@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do ppAst :: Data a => a -> String ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast - -parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token]) +parseOneFile :: FilePath -> FilePath -> IO ParsedSource parseOneFile libdir fileName = do - res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName + res <- Parsers.parseModule libdir fileName case res of Left m -> error (internalDebugShowMessages m) - Right (injectedComments, _dflags, pmod) -> do - let !pmodWithComments = insertCppComments pmod injectedComments - return (pmodWithComments, []) + Right pmod -> return pmod -- --------------------------------------------------------------------- @@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do - let (oldDecls) = map unWrapValBind bs - -- let decls = s:d:oldDecls + let oldDecls = map unWrapValBind bs let oldDecls' = captureLineSpacing oldDecls let (VbSig o:oldBinds) = map wrapValBind oldDecls' o' = setEntryDP o (DifferentLine 2 0) ===================================== utils/check-exact/Parsers.hs ===================================== @@ -46,6 +46,7 @@ module Parsers ( ) where import Preprocess +import Utils import Data.Functor (void) @@ -270,7 +271,10 @@ postParseTransform -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes where - mkAnns (_cs, _, m) = fixModuleComments m + mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs) + noIEDoc (GHC.L l m) = case GHC.hsmodExports m of + Nothing -> GHC.L l m + Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps } fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p ===================================== utils/check-exact/Transform.hs ===================================== @@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Data.FastString -import GHC.Types.SrcLoc import Data.Data import Data.List (unsnoc) @@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r) (a',b') = balanceComments a b r = balanceCommentsList' (b':ls) +balanceCommentsListA :: [LocatedA a ] -> [LocatedA a] +balanceCommentsListA [] = [] +balanceCommentsListA [x] = [x] +balanceCommentsListA (a:b:ls) = (a':r) + where + (a',b') = balanceCommentsA a b + r = balanceCommentsListA (b':ls) + -- |The GHC parser puts all comments appearing between the end of one AST -- item and the beginning of the next as 'annPriorComments' for the second one. -- This function takes two adjacent AST items and moves any 'annPriorComments' @@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt) (HsValBinds _ vb') -> vb' _ -> ValBinds noExtField [] - -balanceCommentsListA :: [LocatedA a] -> [LocatedA a] -balanceCommentsListA [] = [] -balanceCommentsListA [x] = [x] -balanceCommentsListA (a:b:ls) = (a':r) - where - (a',b') = balanceCommentsA a b - r = balanceCommentsListA (b':ls) - -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided @@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs) -- --------------------------------------------------------------------- --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) -splitComments p cs = (before, middle, after) - where - cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmpe (L _ _) = True - - cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p - cmpb (L _ _) = True - - (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) - (before, middle) = break cmpb beforeEnd - - --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsEnd p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - --- | Split comments into ones occurring before the start of the reference --- span, and those after it. -splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsStart p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u) => LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u) moveLeadingComments (L la a) lb = (L la' a, lb') @@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) anchorFromLocatedA :: LocatedA a -> RealSrcSpan anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc --- | Get the full span of interest for comments from a LocatedA. --- This extends up to the last TrailingAnn -fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan -fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr - where - r = epaLocationRealSrcSpan anc - trailing_loc ta = case ta_location ta of - EpaSpan (RealSrcSpan s _) -> [s] - _ -> [] - rr = case reverse (concatMap trailing_loc tas) of - [] -> r - (s:_) -> combineRealSrcSpans r s - -- --------------------------------------------------------------------- balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) ===================================== utils/check-exact/Utils.hs ===================================== @@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining (p2, remaining) = insertTopLevelCppComments p1 toplevel addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) - addCommentsListItem = addComments + addCommentsListItem = addCommentsA addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList) addCommentsList = addComments @@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining _ -> return $ EpAnn anc an ocs + addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) + addCommentsA ann@(EpAnn anc an ocs) = do + case anc of + EpaSpan (RealSrcSpan s _) -> do + unAllocated <- get + let + (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated + balanced = splitCommentsEnd s (EpaComments these) + cs' = sortEpAnnComments (ocs <> balanced) + put rest + return $ EpAnn anc an cs' + + _ -> return $ EpAnn anc an ocs + workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments workInComments ocs [] = ocs workInComments ocs new = cs' @@ -264,9 +278,14 @@ workInComments ocs new = cs' = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new +sortEpAnnComments :: EpAnnComments -> EpAnnComments +sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs) +sortEpAnnComments (EpaCommentsBalanced pc fc) + = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc) + insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment]) insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs - = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3) + = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs)) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs)) where @@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports cs' = workInComments (comments an1) stay _ -> (an1,cs0a) - (mexports', an3, cs1) = - case mexports of - Nothing -> (Nothing, an2, cs0b) - Just exports -> (Just exports', an3', cse) - where - (csh', cs0b') = case am_exports $ anns an2 of - (tokOP, _tokCP, _tokCommas) -> - case tokOP of - (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n) - where - (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) - cs0b - - _ -> ([], cs0b) - hc1' = workInComments (comments an2) csh' - an3' = an2 { comments = hc1' } - (exports', cse) = allocPreceding exports cs0b' - (imports0, cs2) = allocPreceding imports cs1 + (imports0, cs2) = allocPreceding imports cs0b (imports', hc0i) = balanceFirstLocatedAComments imports0 (decls0, cs3) = allocPreceding decls cs2 @@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports -- Either hc0i or hc0d should have comments. Combine them hc0 = hc0i ++ hc0d - (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0 - hc2 = workInComments (comments an3) hc1 - an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 } + (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0 + hc2 = workInComments (comments an2) hc1 + an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 } allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment]) allocPreceding [] cs' = ([], cs') @@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) - data SplitWhere = Before | After splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) @@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p' -- --------------------------------------------------------------------- +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan +fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann + +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan +fullSpanFromEpAnnA (EpAnn anc tas _) = rr + where + r = epaLocationRealSrcSpan anc + trailing_loc ta = case ta_location ta of + EpaSpan (RealSrcSpan s _) -> [s] + _ -> [] + rr = case reverse (concatMap trailing_loc tas) of + [] -> r + (s:_) -> combineRealSrcSpans r s + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) +splitComments p cs = (before, middle, after) + where + cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmpe (L _ _) = True + + cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p + cmpb (L _ _) = True + + (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) + (before, middle) = break cmpb beforeEnd + + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsEnd p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- | Split comments into ones occurring before the start of the reference +-- span, and those after it. +splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsStart p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- --------------------------------------------------------------------- + ghcCommentText :: LEpaComment -> String ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3675b4c51182e05e4e8fab921170748... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3675b4c51182e05e4e8fab921170748... 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