EPA: Comment Order Reversedwip/az/ghc-9.4-epa-backports

Make sure comments captured in the exact print annotations are in
order of increasing location

Closes #20718

(cherry picked from commit e2520df3fffa0cf22fb19c5fb872832d11c07d35)

8 files changed, 270 insertions, 21 deletions

diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 82a5b9bb38..f3a3109c42 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -3009,7 +3009,7 @@ instance MonadP P where
       POk s {
          header_comments = header_comments',
          comment_q = comment_q'
-       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') (reverse newAnns))
+       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns)
 
 getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments
 getCommentsFor (RealSrcSpan l _) = allocateCommentsP l
@@ -3554,7 +3554,7 @@ allocateComments ss comment_q =
     comment_q' = before ++ after
     newAnns = middle
   in
-    (comment_q', newAnns)
+    (comment_q', reverse newAnns)
 
 allocatePriorComments
   :: RealSrcSpan
@@ -3569,24 +3569,20 @@ allocatePriorComments ss comment_q mheader_comments =
     comment_q'= after
   in
     case mheader_comments of
-      Strict.Nothing -> (Strict.Just newAnns, comment_q', [])
-      Strict.Just _ -> (mheader_comments, comment_q', newAnns)
+      Strict.Nothing -> (Strict.Just (reverse newAnns), comment_q', [])
+      Strict.Just _ -> (mheader_comments, comment_q', reverse newAnns)
 
 allocateFinalComments
   :: RealSrcSpan
   -> [LEpaComment]
   -> Strict.Maybe [LEpaComment]
   -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment])
-allocateFinalComments ss comment_q mheader_comments =
-  let
-    cmp (L l _) = anchor l <= ss
-    (before,after) = partition cmp comment_q
-    newAnns = after
-    comment_q'= before
-  in
-    case mheader_comments of
-      Strict.Nothing -> (Strict.Just newAnns, [], comment_q')
-      Strict.Just _ -> (mheader_comments, [], comment_q' ++ newAnns)
+allocateFinalComments _ss comment_q mheader_comments =
+  -- We ignore the RealSrcSpan as the parser currently provides a
+  -- point span at (1,1).
+  case mheader_comments of
+    Strict.Nothing -> (Strict.Just (reverse comment_q), [], [])
+    Strict.Just _ -> (mheader_comments, [], reverse comment_q)
 
 commentToAnnotation :: RealLocated Token -> LEpaComment
 commentToAnnotation (L l (ITdocComment s ll))   = mkLEpaComment l ll (EpaDocComment s)
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index b9bd342dba..92afef026b 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2967,7 +2967,7 @@ instance MonadP PV where
       PV_Ok s {
          pv_header_comments = header_comments',
          pv_comment_q = comment_q'
-       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') (reverse newAnns))
+       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns)
 
 {- Note [Parser-Validator Details]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
index 34d759a794..f25f99cd32 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr
@@ -21,20 +21,20 @@
    (EpaCommentsBalanced
     [(L
       (Anchor
-       { DumpParsedAstComments.hs:(2,1)-(4,4) }
+       { DumpParsedAstComments.hs:1:1-28 }
        (UnchangedAnchor))
       (EpaComment
        (EpaBlockComment
-        "{-/n  Block comment at the beginning/n  -}")
-       { DumpParsedAstComments.hs:1:1-28 }))
+        "{-# LANGUAGE Haskell2010 #-}")
+       { DumpParsedAstComments.hs:1:1 }))
     ,(L
       (Anchor
-       { DumpParsedAstComments.hs:1:1-28 }
+       { DumpParsedAstComments.hs:(2,1)-(4,4) }
        (UnchangedAnchor))
       (EpaComment
        (EpaBlockComment
-        "{-# LANGUAGE Haskell2010 #-}")
-       { DumpParsedAstComments.hs:1:1 }))]
+        "{-/n  Block comment at the beginning/n  -}")
+       { DumpParsedAstComments.hs:1:1-28 }))]
     [(L
       (Anchor
        { DumpParsedAstComments.hs:13:1 }
diff --git a/testsuite/tests/parser/should_compile/T20718.hs b/testsuite/tests/parser/should_compile/T20718.hs
new file mode 100644
index 0000000000..0b1a3e6a0f
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T20718.hs
@@ -0,0 +1,11 @@
+-- top of file 1
+-- top of file 2
+module T20718 where
+
+-- before 1
+-- before 2
+
+x = 1
+
+-- end 1
+-- end 2
diff --git a/testsuite/tests/parser/should_compile/T20718.stderr b/testsuite/tests/parser/should_compile/T20718.stderr
new file mode 100644
index 0000000000..c041db260a
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T20718.stderr
@@ -0,0 +1,162 @@
+
+==================== Parser AST ====================
+
+(L
+ { T20718.hs:1:1 }
+ (HsModule
+  (EpAnn
+   (Anchor
+    { T20718.hs:1:1 }
+    (UnchangedAnchor))
+   (AnnsModule
+    [(AddEpAnn AnnModule (EpaSpan { T20718.hs:3:1-6 }))
+    ,(AddEpAnn AnnWhere (EpaSpan { T20718.hs:3:15-19 }))]
+    (AnnList
+     (Nothing)
+     (Nothing)
+     (Nothing)
+     []
+     []))
+   (EpaCommentsBalanced
+    [(L
+      (Anchor
+       { T20718.hs:1:1-16 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaLineComment
+        "-- top of file 1")
+       { T20718.hs:1:1 }))
+    ,(L
+      (Anchor
+       { T20718.hs:2:1-16 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaLineComment
+        "-- top of file 2")
+       { T20718.hs:1:1-16 }))
+    ,(L
+      (Anchor
+       { T20718.hs:5:1-11 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaLineComment
+        "-- before 1")
+       { T20718.hs:3:15-19 }))
+    ,(L
+      (Anchor
+       { T20718.hs:6:1-11 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaLineComment
+        "-- before 2")
+       { T20718.hs:5:1-11 }))]
+    [(L
+      (Anchor
+       { T20718.hs:12:1 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaEofComment)
+       { T20718.hs:11:1-8 }))]))
+  (VirtualBraces
+   (1))
+  (Just
+   (L
+    (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:3:8-13 })
+    {ModuleName: T20718}))
+  (Nothing)
+  []
+  [(L
+    (SrcSpanAnn (EpAnn
+                 (Anchor
+                  { T20718.hs:8:1-5 }
+                  (UnchangedAnchor))
+                 (AnnListItem
+                  [])
+                 (EpaComments
+                  [(L
+                    (Anchor
+                     { T20718.hs:10:1-8 }
+                     (UnchangedAnchor))
+                    (EpaComment
+                     (EpaLineComment
+                      "-- end 1")
+                     { T20718.hs:8:5 }))
+                  ,(L
+                    (Anchor
+                     { T20718.hs:11:1-8 }
+                     (UnchangedAnchor))
+                    (EpaComment
+                     (EpaLineComment
+                      "-- end 2")
+                     { T20718.hs:10:1-8 }))])) { T20718.hs:8:1-5 })
+    (ValD
+     (NoExtField)
+     (FunBind
+      (NoExtField)
+      (L
+       (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:8:1 })
+       (Unqual
+        {OccName: x}))
+      (MG
+       (NoExtField)
+       (L
+        (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:8:1-5 })
+        [(L
+          (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:8:1-5 })
+          (Match
+           (EpAnn
+            (Anchor
+             { T20718.hs:8:1-5 }
+             (UnchangedAnchor))
+            []
+            (EpaComments
+             []))
+           (FunRhs
+            (L
+             (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:8:1 })
+             (Unqual
+              {OccName: x}))
+            (Prefix)
+            (NoSrcStrict))
+           []
+           (GRHSs
+            (EpaComments
+             [])
+            [(L
+              (SrcSpanAnn
+               (EpAnnNotUsed)
+               { T20718.hs:8:3-5 })
+              (GRHS
+               (EpAnn
+                (Anchor
+                 { T20718.hs:8:3-5 }
+                 (UnchangedAnchor))
+                (GrhsAnn
+                 (Nothing)
+                 (AddEpAnn AnnEqual (EpaSpan { T20718.hs:8:3 })))
+                (EpaComments
+                 []))
+               []
+               (L
+                (SrcSpanAnn (EpAnnNotUsed) { T20718.hs:8:5 })
+                (HsOverLit
+                 (EpAnn
+                  (Anchor
+                   { T20718.hs:8:5 }
+                   (UnchangedAnchor))
+                  (NoEpAnns)
+                  (EpaComments
+                   []))
+                 (OverLit
+                  (NoExtField)
+                  (HsIntegral
+                   (IL
+                    (SourceText 1)
+                    (False)
+                    (1))))))))]
+            (EmptyLocalBinds
+             (NoExtField)))))])
+       (FromSource))
+      [])))]
+  (Nothing)
+  (Nothing)))
diff --git a/testsuite/tests/parser/should_compile/T20718b.hs b/testsuite/tests/parser/should_compile/T20718b.hs
new file mode 100644
index 0000000000..9896dd933e
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T20718b.hs
@@ -0,0 +1,7 @@
+-- header comment 1
+-- header comment 2
+
+module T20718b where
+
+-- trailing comment 1
+-- trailing comment 2
diff --git a/testsuite/tests/parser/should_compile/T20718b.stderr b/testsuite/tests/parser/should_compile/T20718b.stderr
new file mode 100644
index 0000000000..d359e5c5cf
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T20718b.stderr
@@ -0,0 +1,70 @@
+
+==================== Parser AST ====================
+
+(L
+ { T20718b.hs:1:1 }
+ (HsModule
+  (EpAnn
+   (Anchor
+    { T20718b.hs:1:1 }
+    (UnchangedAnchor))
+   (AnnsModule
+    [(AddEpAnn AnnModule (EpaSpan { T20718b.hs:4:1-6 }))
+    ,(AddEpAnn AnnWhere (EpaSpan { T20718b.hs:4:16-20 }))]
+    (AnnList
+     (Nothing)
+     (Nothing)
+     (Nothing)
+     []
+     []))
+   (EpaCommentsBalanced
+    [(L
+      (Anchor
+       { T20718b.hs:1:1-19 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaLineComment
+        "-- header comment 1")
+       { T20718b.hs:1:1 }))
+    ,(L
+      (Anchor
+       { T20718b.hs:2:1-19 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaLineComment
+        "-- header comment 2")
+       { T20718b.hs:1:1-19 }))
+    ,(L
+      (Anchor
+       { T20718b.hs:6:1-21 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaLineComment
+        "-- trailing comment 1")
+       { T20718b.hs:4:16-20 }))
+    ,(L
+      (Anchor
+       { T20718b.hs:7:1-21 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaLineComment
+        "-- trailing comment 2")
+       { T20718b.hs:6:1-21 }))]
+    [(L
+      (Anchor
+       { T20718b.hs:8:1 }
+       (UnchangedAnchor))
+      (EpaComment
+       (EpaEofComment)
+       { T20718b.hs:7:1-21 }))]))
+  (VirtualBraces
+   (1))
+  (Just
+   (L
+    (SrcSpanAnn (EpAnnNotUsed) { T20718b.hs:4:8-14 })
+    {ModuleName: T20718b}))
+  (Nothing)
+  []
+  []
+  (Nothing)
+  (Nothing)))
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index e5116ffd02..ffadeeaf1c 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -188,3 +188,6 @@ test('T20551', normal, compile, [''])
 test('OpaqueParseWarn1', normal, compile, [''])
 test('T20385', normal, compile, [''])
 test('T20385S', normal, compile, [''])
+
+test('T20718',  normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
+test('T20718b',  normal, compile, ['-dsuppress-uniques -ddump-parsed-ast -dkeep-comments'])
\ No newline at end of file