Use correct source spans for EmptyCase

Summary:
The parser's calculation of source spans for `EmptyCase`
expressions was a bit off, leading to some wonky-looking error
messages. Easily fixed with some uses of `comb3` and `sLL`.

Test Plan: make test TEST=T15139

Reviewers: bgamari, simonpj

Reviewed By: simonpj

Subscribers: simonpj, rwbarton, thomie, mpickering, carter

GHC Trac Issues: #15139

Differential Revision: https://phabricator.haskell.org/D4685

4 files changed, 38 insertions, 2 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index a7c875e39e..4c66fd76d6 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2573,7 +2573,8 @@ aexp    :: { LHsExpr GhcPs }
                                            ams (sLL $1 $> $ HsMultiIf noExt
                                                      (reverse $ snd $ unLoc $2))
                                                (mj AnnIf $1:(fst $ unLoc $2)) }
-        | 'case' exp 'of' altslist      {% ams (sLL $1 $> $ HsCase noExt $2 (mkMatchGroup
+        | 'case' exp 'of' altslist      {% ams (L (comb3 $1 $3 $4) $
+                                                   HsCase noExt $2 (mkMatchGroup
                                                    FromSource (snd $ unLoc $4)))
                                                (mj AnnCase $1:mj AnnOf $3
                                                   :(fst $ unLoc $4)) }
@@ -2874,7 +2875,7 @@ altslist :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
                                                ,(reverse (snd $ unLoc $2))) }
         |     vocurly    alts  close { L (getLoc $2) (fst $ unLoc $2
                                         ,(reverse (snd $ unLoc $2))) }
-        | '{'                 '}'    { noLoc ([moc $1,mcc $2],[]) }
+        | '{'                 '}'    { sLL $1 $> ([moc $1,mcc $2],[]) }
         |     vocurly          close { noLoc ([],[]) }
 
 alts    :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
diff --git a/testsuite/tests/parser/should_compile/T15139.hs b/testsuite/tests/parser/should_compile/T15139.hs
new file mode 100644
index 0000000000..9f98bb1319
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T15139.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE TypeOperators #-}
+module T15139 where
+
+import Data.Type.Equality
+
+can'tHappen :: Int :~: Bool
+can'tHappen = undefined
+
+f1, f2, g :: Bool -> Bool
+f1 True = case can'tHappen of {}
+f2 True = case can'tHappen of
+g  True = case () of () -> True
diff --git a/testsuite/tests/parser/should_compile/T15139.stderr b/testsuite/tests/parser/should_compile/T15139.stderr
new file mode 100644
index 0000000000..010bd7440c
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T15139.stderr
@@ -0,0 +1,21 @@
+
+T15139.hs:11:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘f1’: Patterns not matched: False
+   |
+11 | f1 True = case can'tHappen of {}
+   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+T15139.hs:12:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘f2’: Patterns not matched: False
+   |
+12 | f2 True = case can'tHappen of
+   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+T15139.hs:13:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘g’: Patterns not matched: False
+   |
+13 | g  True = case () of () -> True
+   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index f323976df2..ab0a393979 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -115,3 +115,4 @@ test('T13747', normal, compile, [''])
 test('T14189',     normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])
 test('T13986', normal, compile, [''])
 test('T10855', normal, compile, [''])
+test('T15139', normal, compile, ['-Wincomplete-patterns -fdiagnostics-show-caret'])