Improve insertCppComments for more top of module comments

So all tests pass bar the makeDeltaAst ones
alanz · Apr 11, 2024 · 610cb0b · 610cb0b
1 parent 6d08e8e
commit 610cb0b
Show file tree

Hide file tree

Showing 3 changed files with 40 additions and 18 deletions.
diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
@@ -304,7 +304,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 an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3)
   where
     -- Comments at the top level.
     (an0, cs0) =
@@ -337,22 +337,31 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
             cs' = workInComments (comments an1) stay
         _ -> (an1,cs0a)
 
-    (mexports', cs1) =
+    (mexports', an3, cs1) =
       case mexports of
-        Nothing -> (Nothing, cs0b)
-        Just (L l exports) -> (Just (L l exports'), cse)
+        Nothing -> (Nothing, an2, cs0b)
+        Just (L l exports) -> (Just (L l exports'), an3', cse)
                          where
-                           (exports', cse) = allocPreceding exports cs0b
+                           hc1' = workInComments (comments an2) csh'
+                           an3' = an2 { comments = hc1' }
+                           (csh', cs0b') = case al_open $ anns l of
+                               Just (AddEpAnn _ (EpaSpan (RealSrcSpan s _))) ->(h, n)
+                                 where
+                                   (h,n) = break (\(L ll _) -> (ss2pos $ anchor ll) > (ss2pos s) )
+                                       cs0b
+
+                               _ -> ([], cs0b)
+                           (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 }
+    hc1 = workInComments (comments an3) hc0
+    an4 = an3 { comments = hc1 }
 
     allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment])
     allocPreceding [] cs' = ([], cs')
-    allocPreceding (L (EpAnn anc4 an4 cs4) a:xs) cs' = ((L (EpAnn anc4 an4 cs4') a:xs'), rest')
+    allocPreceding (L (EpAnn anc4 an5 cs4) a:xs) cs' = ((L (EpAnn anc4 an5 cs4') a:xs'), rest')
       where
         (rest, these) =
           case anc4 of
@@ -364,19 +373,19 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
 
 balanceFirstDeclComments :: [LHsDecl GhcPs] -> ([LHsDecl GhcPs], [LEpaComment])
 balanceFirstDeclComments [] = ([],[])
-balanceFirstDeclComments ((L (EpAnn anc an csd) a):ds) = (L (EpAnn anc an csd') a:ds, hc')
+balanceFirstDeclComments ((L (EpAnn anc an csd) a):ds) = (L (EpAnn anc an csd0) a:ds, hc')
   where
-    (csd', hc') = case anc of
-        EpaDelta _ _ -> (csd, [])
+    (csd0, hc') = case anc of
         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
+            (attached, header) = break (\(d,_c) -> d /= 1) pcds
             csd' = setPriorComments csd (reverse (map snd attached) ++ inners)
             hc = reverse (map snd header)
+        _ -> (csd, [])
 
 
 

diff --git a/tests/Test.hs b/tests/Test.hs
@@ -139,10 +139,10 @@ mkTests = do
   roundTripMakeDeltaTests <- findTestsMD libdir
   -- prettyRoundTripTests <- findPrettyTests libdir
   return $ TestList [
-                      -- internalTests,
-                      -- roundTripTests
+                   --    internalTests,
+                   --    roundTripTests
                    -- ,
-                     -- (transformTests libdir)
+                   --   (transformTests libdir)
                    -- , (failingTests libdir)
                    -- ,
                    --   roundTripBalanceCommentsTests
@@ -201,9 +201,9 @@ tt' = do
     -- mkParserTest libdir "ghc710" "Expr.hs"
     -- mkParserTestMD libdir "ghc710" "Expr.hs"
 
-    -- mkParserTest libdir "ghc98" "MonoidsFD1.hs"
+    -- mkParserTest libdir "ghc98" "ModuleComments1.hs"
     -- mkParserTestBC libdir "ghc98" "MonoidsFD1.hs"
-    -- mkParserTestMD libdir "ghc98" "MonoidsFD1.hs"
+    mkParserTestMD libdir "ghc98" "ModuleComments1.hs"
 
 
     -- mkParserTest libdir "ghc80" "ForFree.hs"
@@ -214,7 +214,7 @@ tt' = do
     -- mkParserTest libdir "ghc710" "Undefined10a.hs"
 
     -- mkParserTest libdir "ghc710" "CExpected1.hs"
-    mkParserTestMD libdir "ghc710" "CExpected1.hs"
+    -- mkParserTestMD libdir "ghc710" "CExpected1.hs"
 
     -- ExportWarnings_aux.hs
     -- ghc98:7:T23465.hs

diff --git a/tests/examples/ghc98/ModuleComments1.hs b/tests/examples/ghc98/ModuleComments1.hs
@@ -0,0 +1,13 @@
+-- top of module
+module {- c1 -} ModuleComments1 {- c2 -}
+    -- c3
+    (
+    -- c4
+    foo
+    -- c5
+    ) {- c6 -} where {- c7 -}
+-- c8
+
+foo = x
+
+-- eof