EPA: do statement with leading semicolon has wrong anchor

The code

    do; a <- doAsync; b

Generated an incorrect Anchor for the statement list that starts after
the first semicolon.

This commit fixes it.

Closes #20256

6 files changed, 31 insertions, 6 deletions

diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 01c0459866..bb57f39d7b 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -3318,10 +3318,10 @@ apats  :: { [LPat GhcPs] }
 -- Statement sequences
 
 stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) }
-        : '{'           stmts '}'       { $2 >>= \ $2 -> amsrl
-                                          (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) }
+        : '{'           stmts '}'       { $2 >>= \ $2 ->
+                                          amsrl (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) }
         |     vocurly   stmts close     { $2 >>= \ $2 -> amsrl
-                                          (L (gl $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) }
+                                          (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ stmtsAnchor $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) }
 
 --      do { ;; s ; s ; ; s ;; }
 -- The last Stmt should be an expression, but that's hard to enforce
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 8a89bef84d..845f7eb25c 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -39,6 +39,7 @@ module GHC.Parser.PostProcess (
         fromSpecTyVarBndr, fromSpecTyVarBndrs,
         annBinds,
         fixValbindsAnn,
+        stmtsAnchor, stmtsLoc,
 
         cvBindGroup,
         cvBindsAndSigs,
@@ -478,6 +479,18 @@ fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed
 fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)
   = (EpAnn (widenAnchor anchor (map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs)
 
+-- | The 'Anchor' for a stmtlist is based on either the location or
+-- the first semicolon annotion.
+stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Anchor
+stmtsAnchor (L l ((ConsOL (AddEpAnn _ (EpaSpan r)) _), _))
+  = widenAnchorR (Anchor (realSrcSpan l) UnchangedAnchor) r
+stmtsAnchor (L l _) = Anchor (realSrcSpan l) UnchangedAnchor
+
+stmtsLoc :: Located (OrdList AddEpAnn,a) -> SrcSpan
+stmtsLoc (L l ((ConsOL aa _), _))
+  = widenSpan l [aa]
+stmtsLoc (L l _) = l
+
 {- **********************************************************************
 
   #cvBinds-etc# Converting to @HsBinds@, etc.
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 2c4195eeb1..e80655d83f 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -754,3 +754,8 @@ Test20297:
 Test20846:
 	$(CHECK_PPR)   $(LIBDIR) Test20846.hs
 	$(CHECK_EXACT) $(LIBDIR) Test20846.hs
+
+.PHONY: Test20256
+Test20256:
+	$(CHECK_PPR)   $(LIBDIR) Test20256.hs
+	$(CHECK_EXACT) $(LIBDIR) Test20256.hs
diff --git a/testsuite/tests/printer/Test20256.hs b/testsuite/tests/printer/Test20256.hs
new file mode 100644
index 0000000000..4ffa9a76f0
--- /dev/null
+++ b/testsuite/tests/printer/Test20256.hs
@@ -0,0 +1,5 @@
+module Test20256 where
+
+foo = do
+  ; a <- doAsync
+  ; b
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 4562acc8e5..12b3960a7a 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -174,6 +174,7 @@ test('PprCommentPlacement2', [ignore_stderr, req_ppr_deps], makefile_test, ['Ppr
 
 test('Test20243', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20243'])
 test('Test20247', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20247'])
+test('Test20256', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20256'])
 test('Test20258', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20258'])
 test('Test20297', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20297'])
 test('Test20846', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20846'])
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index d170e5e945..b83cc9cd86 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -37,8 +37,8 @@ import GHC.Data.FastString
 
 _tt :: IO ()
 -- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
-_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
--- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
+-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
+_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
 
  -- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" (Just changeRenameCase1)
  -- "../../testsuite/tests/ghc-api/exactprint/LayoutLet2.hs" (Just changeLayoutLet2)
@@ -197,7 +197,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin
  -- "../../testsuite/tests/printer/PprLinearArrow.hs" Nothing
  -- "../../testsuite/tests/printer/PprSemis.hs" Nothing
  -- "../../testsuite/tests/printer/PprEmptyMostly.hs" Nothing
- "../../testsuite/tests/parser/should_compile/DumpSemis.hs" Nothing
+ -- "../../testsuite/tests/parser/should_compile/DumpSemis.hs" Nothing
+ "../../testsuite/tests/printer/Test20256.hs" Nothing
 
 -- cloneT does not need a test, function can be retired