summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2022-03-10 23:23:16 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-05-11 08:23:33 -0400
commit4a4c77ed8f16f157dd647593de58840b024bbd2d (patch)
treeca61146523ef92158c599d9693bd9583c08e6146
parent8500206ea7084f3914efd3fe7f4336f2893eb4ac (diff)
downloadhaskell-4a4c77ed8f16f157dd647593de58840b024bbd2d.tar.gz
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
-rw-r--r--compiler/GHC/Parser.y6
-rw-r--r--compiler/GHC/Parser/PostProcess.hs13
-rw-r--r--testsuite/tests/printer/Makefile5
-rw-r--r--testsuite/tests/printer/Test20256.hs5
-rw-r--r--testsuite/tests/printer/all.T1
-rw-r--r--utils/check-exact/Main.hs7
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