summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2019-02-03 10:27:42 +0200
committerBen Gamari <ben@smart-cactus.org>2019-02-26 12:58:59 -0500
commitf6abc30dbac109f514e469ddfdffc7d2e3c95811 (patch)
treec73d4a5f9521e7c4df38b02319d593aef88c812b
parentca5b476083e4b361720135dcb159980b1bca82de (diff)
downloadhaskell-f6abc30dbac109f514e469ddfdffc7d2e3c95811.tar.gz
Lexer: Alternate Layout Rule injects actual not virtual braces
When the alternate layout rule is activated via a pragma, it injects tokens for { and } to make sure that the source is parsed properly. But it injects ITocurly and ITccurly, rather than their virtual counterparts ITvocurly and ITvccurly. This causes problems for ghc-exactprint, which tries to print these. Likewise, any injected ITsemi should have a zero-width SrcSpan. Test case (the existing T13087.hs) {-# LANGUAGE AlternativeLayoutRule #-} {-# LANGUAGE LambdaCase #-} isOne :: Int -> Bool isOne = \case 1 -> True _ -> False main = return () Closes #16279 (cherry picked from commit c1cf2693d6efddeeeb813cd8995a1be136800d17) (cherry picked from commit e0375ba980fd5639d23a29575efb00c30d97c743)
-rw-r--r--compiler/parser/Lexer.x32
-rw-r--r--testsuite/tests/ghc-api/annotations/Makefile20
-rw-r--r--testsuite/tests/ghc-api/annotations/T16279.stdout30
-rw-r--r--testsuite/tests/ghc-api/annotations/Test16279.hs10
-rw-r--r--testsuite/tests/ghc-api/annotations/all.T2
5 files changed, 79 insertions, 15 deletions
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 10712c9c42..147e678973 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -2687,23 +2687,23 @@ alternativeLayoutRuleToken t
do setAlrExpectingOCurly Nothing
setALRContext (ALRLayout expectingOCurly thisCol : context)
setNextToken t
- return (L thisLoc ITocurly)
+ return (L thisLoc ITvocurly)
| otherwise ->
do setAlrExpectingOCurly Nothing
- setPendingImplicitTokens [L lastLoc ITccurly]
+ setPendingImplicitTokens [L lastLoc ITvccurly]
setNextToken t
- return (L lastLoc ITocurly)
+ return (L lastLoc ITvocurly)
(_, _, Just expectingOCurly) ->
do setAlrExpectingOCurly Nothing
setALRContext (ALRLayout expectingOCurly thisCol : context)
setNextToken t
- return (L thisLoc ITocurly)
+ return (L thisLoc ITvocurly)
-- We do the [] cases earlier than in the spec, as we
-- have an actual EOF token
(ITeof, ALRLayout _ _ : ls, _) ->
do setALRContext ls
setNextToken t
- return (L thisLoc ITccurly)
+ return (L thisLoc ITvccurly)
(ITeof, _, _) ->
return t
-- the other ITeof case omitted; general case below covers it
@@ -2714,7 +2714,7 @@ alternativeLayoutRuleToken t
| newLine ->
do setPendingImplicitTokens [t]
setALRContext ls
- return (L thisLoc ITccurly)
+ return (L thisLoc ITvccurly)
-- This next case is to handle a transitional issue:
(ITwhere, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
@@ -2726,7 +2726,7 @@ alternativeLayoutRuleToken t
setNextToken t
-- Note that we use lastLoc, as we may need to close
-- more layouts, or give a semicolon
- return (L lastLoc ITccurly)
+ return (L lastLoc ITvccurly)
-- This next case is to handle a transitional issue:
(ITvbar, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
@@ -2738,17 +2738,19 @@ alternativeLayoutRuleToken t
setNextToken t
-- Note that we use lastLoc, as we may need to close
-- more layouts, or give a semicolon
- return (L lastLoc ITccurly)
+ return (L lastLoc ITvccurly)
(_, ALRLayout _ col : ls, _)
| newLine && thisCol == col ->
do setNextToken t
- return (L thisLoc ITsemi)
+ let loc = realSrcSpanStart thisLoc
+ zeroWidthLoc = mkRealSrcSpan loc loc
+ return (L zeroWidthLoc ITsemi)
| newLine && thisCol < col ->
do setALRContext ls
setNextToken t
-- Note that we use lastLoc, as we may need to close
-- more layouts, or give a semicolon
- return (L lastLoc ITccurly)
+ return (L lastLoc ITvccurly)
-- We need to handle close before open, as 'then' is both
-- an open and a close
(u, _, _)
@@ -2757,7 +2759,7 @@ alternativeLayoutRuleToken t
ALRLayout _ _ : ls ->
do setALRContext ls
setNextToken t
- return (L thisLoc ITccurly)
+ return (L thisLoc ITvccurly)
ALRNoLayout _ isLet : ls ->
do let ls' = if isALRopen u
then ALRNoLayout (containsCommas u) False : ls
@@ -2780,21 +2782,21 @@ alternativeLayoutRuleToken t
(ITin, ALRLayout ALRLayoutLet _ : ls, _) ->
do setALRContext ls
setPendingImplicitTokens [t]
- return (L thisLoc ITccurly)
+ return (L thisLoc ITvccurly)
(ITin, ALRLayout _ _ : ls, _) ->
do setALRContext ls
setNextToken t
- return (L thisLoc ITccurly)
+ return (L thisLoc ITvccurly)
-- the other ITin case omitted; general case below covers it
(ITcomma, ALRLayout _ _ : ls, _)
| topNoLayoutContainsCommas ls ->
do setALRContext ls
setNextToken t
- return (L thisLoc ITccurly)
+ return (L thisLoc ITvccurly)
(ITwhere, ALRLayout ALRLayoutDo _ : ls, _) ->
do setALRContext ls
setPendingImplicitTokens [t]
- return (L thisLoc ITccurly)
+ return (L thisLoc ITvccurly)
-- the other ITwhere case omitted; general case below covers it
(_, _, _) -> return t
diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile
index 98b45744ce..f293810d20 100644
--- a/testsuite/tests/ghc-api/annotations/Makefile
+++ b/testsuite/tests/ghc-api/annotations/Makefile
@@ -145,3 +145,23 @@ T13163:
.PHONY: T15303
T15303:
$(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test15303.hs
+
+.PHONY: T16212
+T16212:
+ $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16212.hs
+
+.PHONY: T16230
+T16230:
+ $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16230.hs
+
+.PHONY: T16236
+T16236:
+ $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16236.hs
+
+.PHONY: StarBinderAnns
+StarBinderAnns:
+ $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" StarBinderAnns.hs
+
+.PHONY: T16279
+T16279:
+ $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16279.hs
diff --git a/testsuite/tests/ghc-api/annotations/T16279.stdout b/testsuite/tests/ghc-api/annotations/T16279.stdout
new file mode 100644
index 0000000000..7dac950679
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T16279.stdout
@@ -0,0 +1,30 @@
+---Unattached Annotation Problems (should be empty list)---
+[]
+---Ann before enclosing span problem (should be empty list)---
+[
+
+]
+
+---Annotations-----------------------
+-- SrcSpan the annotation is attached to, AnnKeywordId,
+-- list of locations the keyword item appears in
+[
+((Test16279.hs:5:1-20,AnnDcolon), [Test16279.hs:5:7-8]),
+((Test16279.hs:5:1-20,AnnSemi), [Test16279.hs:6:1]),
+((Test16279.hs:5:10-12,AnnRarrow), [Test16279.hs:5:14-15]),
+((Test16279.hs:5:10-20,AnnRarrow), [Test16279.hs:5:14-15]),
+((Test16279.hs:(6,1)-(7,24),AnnEqual), [Test16279.hs:6:7]),
+((Test16279.hs:(6,1)-(7,24),AnnFunId), [Test16279.hs:6:1-5]),
+((Test16279.hs:(6,1)-(7,24),AnnSemi), [Test16279.hs:9:1]),
+((Test16279.hs:(6,9)-(7,24),AnnCase), [Test16279.hs:6:10-13]),
+((Test16279.hs:(6,9)-(7,24),AnnLam), [Test16279.hs:6:9]),
+((Test16279.hs:6:15-23,AnnSemi), [Test16279.hs:7:15]),
+((Test16279.hs:6:17-23,AnnRarrow), [Test16279.hs:6:17-18]),
+((Test16279.hs:7:17-24,AnnRarrow), [Test16279.hs:7:17-18]),
+((Test16279.hs:9:1-16,AnnEqual), [Test16279.hs:9:6]),
+((Test16279.hs:9:1-16,AnnFunId), [Test16279.hs:9:1-4]),
+((Test16279.hs:9:1-16,AnnSemi), [Test16279.hs:11:1]),
+((Test16279.hs:9:15-16,AnnCloseP), [Test16279.hs:9:16]),
+((Test16279.hs:9:15-16,AnnOpenP), [Test16279.hs:9:15]),
+((<no location info>,AnnEofPos), [Test16279.hs:11:1])
+] \ No newline at end of file
diff --git a/testsuite/tests/ghc-api/annotations/Test16279.hs b/testsuite/tests/ghc-api/annotations/Test16279.hs
new file mode 100644
index 0000000000..7817edadc5
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/Test16279.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE AlternativeLayoutRule #-}
+{-# LANGUAGE LambdaCase #-}
+-- duplicate of T13087.hs
+
+isOne :: Int -> Bool
+isOne = \case 1 -> True
+ _ -> False
+
+main = return ()
+
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index 666cb3f044..b3f437aa4a 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -59,3 +59,5 @@ test('T13163', [extra_files(['Test13163.hs']),
ignore_stderr], run_command, ['$MAKE -s --no-print-directory T13163'])
test('T15303', [extra_files(['Test15303.hs']),
ignore_stderr], run_command, ['$MAKE -s --no-print-directory T15303'])
+test('T16279', [extra_files(['Test16279.hs']),
+ ignore_stderr], run_command, ['$MAKE -s --no-print-directory T16279'])