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

5 files changed, 63 insertions, 15 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 0606c56297..8219390e7e 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -2697,23 +2697,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
@@ -2724,7 +2724,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 ->
@@ -2736,7 +2736,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 ->
@@ -2748,17 +2748,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, _, _)
@@ -2767,7 +2769,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
@@ -2790,21 +2792,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 da3be434ff..f293810d20 100644
--- a/testsuite/tests/ghc-api/annotations/Makefile
+++ b/testsuite/tests/ghc-api/annotations/Makefile
@@ -161,3 +161,7 @@ T16236:
 .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 8635ba1934..1d44ac0816 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -67,3 +67,5 @@ test('T16236',      [extra_files(['Test16236.hs']),
                      ignore_stderr], makefile_test, ['T16236'])
 test('StarBinderAnns',      [extra_files(['StarBinderAnns.hs']),
                      ignore_stderr], makefile_test, ['StarBinderAnns'])
+test('T16279',      [extra_files(['Test16279.hs']),
+                     ignore_stderr], makefile_test, ['T16279'])