From 5ebb2f92795fc26f629108061630e14e98d67e2b Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 10 Apr 2024 22:18:51 +0100 Subject: [PATCH] Stash. Tests pass, after backing out insertCppComments change --- src/Language/Haskell/GHC/ExactPrint/Utils.hs | 45 ++------------------ tests/Test.hs | 27 ++++++------ 2 files changed, 16 insertions(+), 56 deletions(-) diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs index 6fcf6972..190b7348 100644 --- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs @@ -303,7 +303,7 @@ workInComments ocs new = cs' insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment]) insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs - = (HsModule (XModulePs an3 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3) + = (HsModule (XModulePs an2 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3) where -- Comments at the top level. (an0, cs0) = @@ -334,7 +334,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports where (stay,cs0b') = break (\(L ll _) -> (ss2pos $ anchor ll) > (ss2pos $ s)) cs0a cs' = workInComments (comments an1) stay - _ -> (an1,cs0a) + _ -> (an1,cs0) (mexports', cs1) = case mexports of @@ -343,11 +343,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports where (exports', cse) = allocPreceding exports cs0b (imports', cs2) = allocPreceding imports cs1 - - (decls0, cs3) = allocPreceding decls cs2 - (decls', hc0) = balanceFirstDeclComments decls0 - hc1 = workInComments (comments an2) hc0 - an3 = an2 { comments = hc1 } + (decls', cs3) = allocPreceding decls cs2 allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment]) allocPreceding [] cs' = ([], cs') @@ -361,39 +357,6 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports cs4' = workInComments cs4 these (xs',rest') = allocPreceding xs rest -balanceFirstDeclComments :: [LHsDecl GhcPs] -> ([LHsDecl GhcPs], [LEpaComment]) -balanceFirstDeclComments [] = ([],[]) -balanceFirstDeclComments ((L (EpAnn anc an csd) a):ds) = (L (EpAnn anc an csd') a:ds, hc') - where - (csd', hc') = case anc of - EpaDelta _ _ -> (csd, []) - EpaSpan (RealSrcSpan s _) -> (csd', hc) - `debug` ("balanceFirstDeclComments: (csd,csd',attached,header)=" ++ showAst (csd,csd',attached,header)) - where - (priors, inners) = break (\(L ll _) -> (ss2pos $ anchor ll) > (ss2pos s) ) - (priorComments csd) - pcds = priorCommentsDeltas' s priors - (attached, header) = break (\(d,c) -> d /= 1) pcds - csd' = setPriorComments csd (reverse (map snd attached) ++ inners) - hc = reverse (map snd header) - - - -priorCommentsDeltas' :: RealSrcSpan -> [LEpaComment] - -> [(Int, LEpaComment)] -priorCommentsDeltas' r cs = go r (reverse cs) - where - go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] - go _ [] = [] - go _ (la@(L l@(EpaDelta dp _) _):las) = (deltaLine dp, la) : go (anchor l) las - go rs' (la@(L l _):las) = deltaComment rs' la : go (anchor l) las - - deltaComment :: RealSrcSpan -> LEpaComment -> (Int, LEpaComment) - deltaComment rs' (L loc c) = (abs(ll - al), L loc c) - where - (al,_) = ss2pos rs' - (ll,_) = ss2pos (anchor loc) - allocatePriorComments :: Pos -> [LEpaComment] @@ -491,7 +454,7 @@ mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments mkEpaComments priorCs [] = EpaComments (map comment2LEpaComment priorCs) mkEpaComments priorCs postCs - = epaCommentsBalanced (map comment2LEpaComment priorCs) (map comment2LEpaComment postCs) + = EpaCommentsBalanced (map comment2LEpaComment priorCs) (map comment2LEpaComment postCs) comment2LEpaComment :: Comment -> LEpaComment comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r diff --git a/tests/Test.hs b/tests/Test.hs index 02eec5a9..97d4d468 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -139,14 +139,14 @@ mkTests = do roundTripMakeDeltaTests <- findTestsMD libdir -- prettyRoundTripTests <- findPrettyTests libdir return $ TestList [ - -- internalTests, - -- roundTripTests - -- , - -- (transformTests libdir) - -- , (failingTests libdir) - -- , - -- roundTripBalanceCommentsTests - -- , + internalTests, + roundTripTests + , + (transformTests libdir) + , (failingTests libdir) + , + roundTripBalanceCommentsTests + , roundTripMakeDeltaTests ] @@ -199,7 +199,7 @@ tt' = do runTestText (putTextToHandle stdout True) $ TestList [ -- mkParserTest libdir "ghc710" "Expr.hs" - -- mkParserTestMD libdir "ghc710" "Expr.hs" + mkParserTestMD libdir "ghc710" "Expr.hs" -- mkParserTest libdir "ghc98" "MonoidsFD1.hs" -- mkParserTestBC libdir "ghc98" "MonoidsFD1.hs" @@ -209,12 +209,9 @@ tt' = do -- mkParserTest libdir "ghc80" "ForFree.hs" -- mkParserTestMD libdir "ghc80" "ForFree.hs" - -- mkParserTest libdir "transform" "WhereIn3b.hs" - -- mkParserTest libdir "ghc710" "EmptyMostlyTrailing.hs" - -- mkParserTest libdir "ghc710" "Undefined10a.hs" - - -- mkParserTest libdir "ghc710" "CExpected.hs" - mkParserTestMD libdir "ghc710" "CExpected.hs" + -- Current failures (makeDeltaAst only) + -- mkParserTest libdir "ghc82" "Completesig03A.hs" + -- mkParserTestMD libdir "ghc82" "Completesig03A.hs" -- ExportWarnings_aux.hs -- ghc98:7:T23465.hs