EPA: When splitting out header comments, keep ones for first declwip/az/epa-split-header-comments

Any comments immediately preceding the first declaration are no longer
kept as header comments, but attach to the first declaration instead.

5 files changed, 105 insertions, 55 deletions

diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index a116aec66c..dfccebce86 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -3676,6 +3676,25 @@ allocateComments ss comment_q =
   in
     (comment_q', reverse newAnns)
 
+-- Comments appearing without a line-break before the first
+-- declaration are associated with the declaration
+splitPriorComments
+  :: RealSrcSpan
+  -> [LEpaComment]
+  -> ([LEpaComment], [LEpaComment])
+splitPriorComments ss prior_comments =
+  let
+    -- True if there is only one line between the earlier and later span
+    cmp later earlier
+         = srcSpanStartLine later - srcSpanEndLine earlier == 1
+
+    go decl _ [] = ([],decl)
+    go decl r (c@(L l _):cs) = if cmp r (anchor l)
+                              then go (c:decl) (anchor l) cs
+                              else (reverse (c:cs), decl)
+  in
+    go [] ss prior_comments
+
 allocatePriorComments
   :: RealSrcSpan
   -> [LEpaComment]
@@ -3684,12 +3703,13 @@ allocatePriorComments
 allocatePriorComments ss comment_q mheader_comments =
   let
     cmp (L l _) = anchor l <= ss
-    (before,after) = partition cmp comment_q
-    newAnns = before
+    (newAnns,after) = partition cmp comment_q
     comment_q'= after
+    (prior_comments, decl_comments) = splitPriorComments ss newAnns
   in
     case mheader_comments of
-      Strict.Nothing -> (Strict.Just (reverse newAnns), comment_q', [])
+      Strict.Nothing -> (Strict.Just prior_comments, comment_q', decl_comments)
+      -- Strict.Nothing -> (Strict.Just [], comment_q', newAnns)
       Strict.Just _ -> (mheader_comments, comment_q', reverse newAnns)
 
 allocateFinalComments
diff --git a/testsuite/tests/ghc-api/exactprint/Test20239.stderr b/testsuite/tests/ghc-api/exactprint/Test20239.stderr
index 2bac5ab532..bcbb818b05 100644
--- a/testsuite/tests/ghc-api/exactprint/Test20239.stderr
+++ b/testsuite/tests/ghc-api/exactprint/Test20239.stderr
@@ -19,14 +19,7 @@
       []
       []))
     (EpaCommentsBalanced
-     [(L
-       (Anchor
-        { Test20239.hs:3:1-28 }
-        (UnchangedAnchor))
-       (EpaComment
-        (EpaLineComment
-         "-- | Leading Haddock Comment")
-        { Test20239.hs:1:18-22 }))]
+     []
      [(L
        (Anchor
         { Test20239.hs:8:1 }
@@ -54,6 +47,14 @@
                  (EpaComments
                   [(L
                     (Anchor
+                     { Test20239.hs:3:1-28 }
+                     (UnchangedAnchor))
+                    (EpaComment
+                     (EpaLineComment
+                      "-- | Leading Haddock Comment")
+                     { Test20239.hs:1:18-22 }))
+                  ,(L
+                    (Anchor
                      { Test20239.hs:7:34-63 }
                      (UnchangedAnchor))
                     (EpaComment
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAstComments.hs b/testsuite/tests/parser/should_compile/DumpParsedAstComments.hs
index d7c51b23b1..62dc878213 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAstComments.hs
+++ b/testsuite/tests/parser/should_compile/DumpParsedAstComments.hs
@@ -4,6 +4,10 @@
   -}
 module DumpParsedAstComments where
 
+-- Other comment
+
+-- comment 1 for foo
+-- comment 2 for foo
 foo = do
   -- normal comment
   1
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
index d453ae5de1..0f451eeb14 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
@@ -34,15 +34,23 @@
         (UnchangedAnchor))
        (EpaComment
         (EpaBlockComment
-         "{-\n  Block comment at the beginning\n  -}")
-        { DumpParsedAstComments.hs:1:1-28 }))]
+         "{-/n  Block comment at the beginning/n  -}")
+        { DumpParsedAstComments.hs:1:1-28 }))
+     ,(L
+       (Anchor
+        { DumpParsedAstComments.hs:7:1-16 }
+        (UnchangedAnchor))
+       (EpaComment
+        (EpaLineComment
+         "-- Other comment")
+        { DumpParsedAstComments.hs:5:30-34 }))]
      [(L
        (Anchor
-        { DumpParsedAstComments.hs:13:1 }
+        { DumpParsedAstComments.hs:17:1 }
         (UnchangedAnchor))
        (EpaComment
         (EpaEofComment)
-        { DumpParsedAstComments.hs:13:1 }))]))
+        { DumpParsedAstComments.hs:17:1 }))]))
    (VirtualBraces
     (1))
    (Nothing)
@@ -56,47 +64,63 @@
   [(L
     (SrcSpanAnn (EpAnn
                  (Anchor
-                  { DumpParsedAstComments.hs:(7,1)-(9,3) }
+                  { DumpParsedAstComments.hs:(11,1)-(13,3) }
                   (UnchangedAnchor))
                  (AnnListItem
                   [])
                  (EpaComments
                   [(L
                     (Anchor
-                     { DumpParsedAstComments.hs:11:1-20 }
+                     { DumpParsedAstComments.hs:9:1-20 }
+                     (UnchangedAnchor))
+                    (EpaComment
+                     (EpaLineComment
+                      "-- comment 1 for foo")
+                     { DumpParsedAstComments.hs:7:1-16 }))
+                  ,(L
+                    (Anchor
+                     { DumpParsedAstComments.hs:10:1-20 }
+                     (UnchangedAnchor))
+                    (EpaComment
+                     (EpaLineComment
+                      "-- comment 2 for foo")
+                     { DumpParsedAstComments.hs:9:1-20 }))
+                  ,(L
+                    (Anchor
+                     { DumpParsedAstComments.hs:15:1-20 }
                      (UnchangedAnchor))
                     (EpaComment
                      (EpaLineComment
                       "-- | Haddock comment")
-                     { DumpParsedAstComments.hs:9:3
-                        }))])) { DumpParsedAstComments.hs:(7,1)-(9,3) })
+                     { DumpParsedAstComments.hs:13:3
+                        }))])) { DumpParsedAstComments.hs:(11,1)-(13,3) })
     (ValD
      (NoExtField)
      (FunBind
       (NoExtField)
       (L
-       (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:7:1-3 })
+       (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:11:1-3 })
        (Unqual
         {OccName: foo}))
       (MG
        (FromSource)
        (L
-        (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(7,1)-(9,3)
+        (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(11,1)-(13,3)
                                       })
         [(L
-          (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(7,1)-(9,3)
+          (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(11,1)-(13,3)
                                         })
           (Match
            (EpAnn
             (Anchor
-             { DumpParsedAstComments.hs:(7,1)-(9,3) }
+             { DumpParsedAstComments.hs:(11,1)-(13,3) }
              (UnchangedAnchor))
             []
             (EpaComments
              []))
            (FunRhs
             (L
-             (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:7:1-3 })
+             (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:11:1-3 })
              (Unqual
               {OccName: foo}))
             (Prefix)
@@ -108,72 +132,72 @@
             [(L
               (SrcSpanAnn
                (EpAnnNotUsed)
-               { DumpParsedAstComments.hs:(7,5)-(9,3) })
+               { DumpParsedAstComments.hs:(11,5)-(13,3) })
               (GRHS
                (EpAnn
                 (Anchor
-                 { DumpParsedAstComments.hs:(7,5)-(9,3) }
+                 { DumpParsedAstComments.hs:(11,5)-(13,3) }
                  (UnchangedAnchor))
                 (GrhsAnn
                  (Nothing)
-                 (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:7:5 })))
+                 (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:11:5 })))
                 (EpaComments
                  []))
                []
                (L
-                (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(7,7)-(9,3)
+                (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:(11,7)-(13,3)
                                               })
                 (HsDo
                  (EpAnn
                   (Anchor
-                   { DumpParsedAstComments.hs:(7,7)-(9,3) }
+                   { DumpParsedAstComments.hs:(11,7)-(13,3) }
                    (UnchangedAnchor))
                   (AnnList
                    (Just
                     (Anchor
-                     { DumpParsedAstComments.hs:9:3 }
+                     { DumpParsedAstComments.hs:13:3 }
                      (UnchangedAnchor)))
                    (Nothing)
                    (Nothing)
-                   [(AddEpAnn AnnDo (EpaSpan { DumpParsedAstComments.hs:7:7-8 }))]
+                   [(AddEpAnn AnnDo (EpaSpan { DumpParsedAstComments.hs:11:7-8 }))]
                    [])
                   (EpaComments
                    [(L
                      (Anchor
-                      { DumpParsedAstComments.hs:8:3-19 }
+                      { DumpParsedAstComments.hs:12:3-19 }
                       (UnchangedAnchor))
                      (EpaComment
                       (EpaLineComment
                        "-- normal comment")
-                      { DumpParsedAstComments.hs:7:7-8 }))]))
+                      { DumpParsedAstComments.hs:11:7-8 }))]))
                  (DoExpr
                   (Nothing))
                  (L
                   (SrcSpanAnn (EpAnn
                                (Anchor
-                                { DumpParsedAstComments.hs:9:3 }
+                                { DumpParsedAstComments.hs:13:3 }
                                 (UnchangedAnchor))
                                (AnnList
                                 (Just
                                  (Anchor
-                                  { DumpParsedAstComments.hs:9:3 }
+                                  { DumpParsedAstComments.hs:13:3 }
                                   (UnchangedAnchor)))
                                 (Nothing)
                                 (Nothing)
                                 []
                                 [])
                                (EpaComments
-                                [])) { DumpParsedAstComments.hs:9:3 })
+                                [])) { DumpParsedAstComments.hs:13:3 })
                   [(L
-                    (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:9:3 })
+                    (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:13:3 })
                     (BodyStmt
                      (NoExtField)
                      (L
-                      (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:9:3 })
+                      (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:13:3 })
                       (HsOverLit
                        (EpAnn
                         (Anchor
-                         { DumpParsedAstComments.hs:9:3 }
+                         { DumpParsedAstComments.hs:13:3 }
                          (UnchangedAnchor))
                         (NoEpAnns)
                         (EpaComments
@@ -192,37 +216,37 @@
   ,(L
     (SrcSpanAnn (EpAnn
                  (Anchor
-                  { DumpParsedAstComments.hs:12:1-23 }
+                  { DumpParsedAstComments.hs:16:1-23 }
                   (UnchangedAnchor))
                  (AnnListItem
                   [])
                  (EpaComments
-                  [])) { DumpParsedAstComments.hs:12:1-23 })
+                  [])) { DumpParsedAstComments.hs:16:1-23 })
     (ValD
      (NoExtField)
      (FunBind
       (NoExtField)
       (L
-       (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-4 })
+       (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-4 })
        (Unqual
         {OccName: main}))
       (MG
        (FromSource)
        (L
-        (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-23 })
+        (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-23 })
         [(L
-          (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-23 })
+          (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-23 })
           (Match
            (EpAnn
             (Anchor
-             { DumpParsedAstComments.hs:12:1-23 }
+             { DumpParsedAstComments.hs:16:1-23 }
              (UnchangedAnchor))
             []
             (EpaComments
              []))
            (FunRhs
             (L
-             (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:1-4 })
+             (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:1-4 })
              (Unqual
               {OccName: main}))
             (Prefix)
@@ -234,42 +258,42 @@
             [(L
               (SrcSpanAnn
                (EpAnnNotUsed)
-               { DumpParsedAstComments.hs:12:6-23 })
+               { DumpParsedAstComments.hs:16:6-23 })
               (GRHS
                (EpAnn
                 (Anchor
-                 { DumpParsedAstComments.hs:12:6-23 }
+                 { DumpParsedAstComments.hs:16:6-23 }
                  (UnchangedAnchor))
                 (GrhsAnn
                  (Nothing)
-                 (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:12:6 })))
+                 (AddEpAnn AnnEqual (EpaSpan { DumpParsedAstComments.hs:16:6 })))
                 (EpaComments
                  []))
                []
                (L
-                (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:8-23 })
+                (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:8-23 })
                 (HsApp
                  (EpAnn
                   (Anchor
-                   { DumpParsedAstComments.hs:12:8-23 }
+                   { DumpParsedAstComments.hs:16:8-23 }
                    (UnchangedAnchor))
                   (NoEpAnns)
                   (EpaComments
                    []))
                  (L
-                  (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:8-15 })
+                  (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:8-15 })
                   (HsVar
                    (NoExtField)
                    (L
-                    (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:8-15 })
+                    (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:8-15 })
                     (Unqual
                      {OccName: putStrLn}))))
                  (L
-                  (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:12:17-23 })
+                  (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAstComments.hs:16:17-23 })
                   (HsLit
                    (EpAnn
                     (Anchor
-                     { DumpParsedAstComments.hs:12:17-23 }
+                     { DumpParsedAstComments.hs:16:17-23 }
                      (UnchangedAnchor))
                     (NoEpAnns)
                     (EpaComments
diff --git a/testsuite/tests/printer/Ppr031.hs b/testsuite/tests/printer/Ppr031.hs
index b31896a9fc..78396c4220 100644
--- a/testsuite/tests/printer/Ppr031.hs
+++ b/testsuite/tests/printer/Ppr031.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE ImplicitParams, NamedFieldPuns, ParallelListComp, PatternGuards #-}
+
 spec :: Spec
 spec = do
   describe "split4'8" $ do