Stash. Tests pass, after backing out insertCppComments change

alanz · Apr 10, 2024 · 5ebb2f9 · 5ebb2f9
1 parent b6d7750
commit 5ebb2f9
Show file tree

Hide file tree

Showing 2 changed files with 16 additions and 56 deletions.
diff --git 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
@@ -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