summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2022-03-07 22:23:29 +0000
committerAlan Zimmerman <alan.zimm@gmail.com>2022-03-07 23:04:15 +0000
commitf822619d71d270adcfb09e30dcf7ba0900f3b63a (patch)
treeeda2082c7a9dd9224878b30aaae178d9602d2e9f
parent7a02aeb8785d5741f36287c89ffba7b50d29e853 (diff)
downloadhaskell-wip/az/T20247.tar.gz
EPA: let stmt with semicolon has wrong anchorwip/az/T20247
The code let ;x =1 Captures the semicolon annotation, but did not widen the anchor in the ValBinds. Fix that. Closes #20247
-rw-r--r--compiler/GHC/Parser.y2
-rw-r--r--compiler/GHC/Parser/Annotation.hs8
-rw-r--r--compiler/GHC/Parser/PostProcess.hs7
-rw-r--r--testsuite/tests/printer/Makefile6
-rw-r--r--testsuite/tests/printer/Test20247.hs4
-rw-r--r--testsuite/tests/printer/all.T1
6 files changed, 25 insertions, 3 deletions
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index a11a438d89..90b17018ff 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1791,7 +1791,7 @@ binds :: { Located (HsLocalBinds GhcPs) }
-- No type declarations
: decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)
; cs <- getCommentsFor (gl $1)
- ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (fst $ unLoc $1) cs) val_binds)} }
+ ; return (sL1 $1 $ HsValBinds (fixValbindsAnn $ EpAnn (glR $1) (fst $ unLoc $1) cs) val_binds)} }
| '{' dbinds '}' {% acs (\cs -> (L (comb3 $1 $2 $3)
$ HsIPBinds (EpAnn (glR $1) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 1f48615aec..4f7525842f 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -43,7 +43,8 @@ module GHC.Parser.Annotation (
AnnSortKey(..),
-- ** Trailing annotations in lists
- TrailingAnn(..), addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN,
+ TrailingAnn(..), trailingAnnToAddEpAnn,
+ addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN,
-- ** Utilities for converting between different 'GenLocated' when
-- ** we do not care about the annotations.
@@ -806,6 +807,11 @@ data AnnSortKey
-- ---------------------------------------------------------------------
+-- | Convert a 'TrailingAnn' to an 'AddEpAnn'
+trailingAnnToAddEpAnn :: TrailingAnn -> AddEpAnn
+trailingAnnToAddEpAnn (AddSemiAnn ss) = AddEpAnn AnnSemi ss
+trailingAnnToAddEpAnn (AddCommaAnn ss) = AddEpAnn AnnComma ss
+trailingAnnToAddEpAnn (AddVbarAnn ss) = AddEpAnn AnnVbar ss
-- | Helper function used in the parser to add a 'TrailingAnn' items
-- to an existing annotation.
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index b9be24259a..f5c7a513c7 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -37,6 +37,7 @@ module GHC.Parser.PostProcess (
setRdrNameSpace,
fromSpecTyVarBndr, fromSpecTyVarBndrs,
annBinds,
+ fixValbindsAnn,
cvBindGroup,
cvBindsAndSigs,
@@ -471,6 +472,11 @@ patch_anchor r1 (Anchor r0 op) = Anchor r op
where
r = if srcSpanStartLine r0 < 0 then r1 else r0
+fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList
+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)
+
{- **********************************************************************
#cvBinds-etc# Converting to @HsBinds@, etc.
@@ -1002,7 +1008,6 @@ checkTyClHdr is_cls ty
newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) =
let
lr = combineRealSrcSpans (realSrcSpan l) (anchor as)
- -- lr = widenAnchorR as (realSrcSpan l)
an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c []) cs)
in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
newAnns _ EpAnnNotUsed = panic "missing AnnParen"
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 749315c60a..2c4195eeb1 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -734,6 +734,12 @@ Test20243:
$(CHECK_PPR) $(LIBDIR) Test20243.hs
$(CHECK_EXACT) $(LIBDIR) Test20243.hs
+.PHONY: Test20247
+Test20247:
+ $(CHECK_PPR) $(LIBDIR) Test20247.hs
+ $(CHECK_EXACT) $(LIBDIR) Test20247.hs
+
+
.PHONY: Test20258
Test20258:
$(CHECK_PPR) $(LIBDIR) Test20258.hs
diff --git a/testsuite/tests/printer/Test20247.hs b/testsuite/tests/printer/Test20247.hs
new file mode 100644
index 0000000000..8c2521fe9a
--- /dev/null
+++ b/testsuite/tests/printer/Test20247.hs
@@ -0,0 +1,4 @@
+module Test20247 where
+
+foo = do
+ let ;x =1
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 3d7c28e453..4562acc8e5 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -173,6 +173,7 @@ test('PprUnicodeSyntax', [ignore_stderr, req_ppr_deps], makefile_test, ['PprUnic
test('PprCommentPlacement2', [ignore_stderr, req_ppr_deps], makefile_test, ['PprCommentPlacement2'])
test('Test20243', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20243'])
+test('Test20247', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20247'])
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'])