Add caret diagnostics

This is controlled by -f[no-]diagnostics-show-caret.

Example of what it looks like:
```
    |
 42 |     x = 1 + ()
    |         ^^^^^^
```
This is appended to each diagnostic message.

Test Plan:
testsuite/tests/warnings/should_fail/CaretDiagnostics1
testsuite/tests/warnings/should_fail/CaretDiagnostics2

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj, bgamari

Subscribers: joehillen, mpickering, Phyx, simonpj, alanz, thomie

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

GHC Trac Issues: #8809

9 files changed, 110 insertions, 0 deletions

diff --git a/testsuite/mk/test.mk b/testsuite/mk/test.mk
index 16be955992..a44e200d49 100644
--- a/testsuite/mk/test.mk
+++ b/testsuite/mk/test.mk
@@ -47,6 +47,7 @@ ifeq "$(MinGhcVersion801)" "YES"
 # Turn off any VT800 codes in the output or they wreak havoc on the
 # testsuite output.
 TEST_HC_OPTS += -fdiagnostics-color=never
+TEST_HC_OPTS += -fno-diagnostics-show-caret
 endif
 
 # Add the no-debug-output last as it is often convenient to copy the test invocation
diff --git a/testsuite/tests/ghci/scripts/T9293.stdout b/testsuite/tests/ghci/scripts/T9293.stdout
index 02ee22c7e8..b2de5417a2 100644
--- a/testsuite/tests/ghci/scripts/T9293.stdout
+++ b/testsuite/tests/ghci/scripts/T9293.stdout
@@ -5,6 +5,7 @@ with the following modifiers:
   -XNondecreasingIndentation
 GHCi-specific dynamic flag settings:
 other dynamic, non-language, flag settings:
+  -fno-diagnostics-show-caret
   -fno-ghci-history
   -fimplicit-import-qualified
   -fshow-warning-groups
@@ -20,6 +21,7 @@ with the following modifiers:
   -XNondecreasingIndentation
 GHCi-specific dynamic flag settings:
 other dynamic, non-language, flag settings:
+  -fno-diagnostics-show-caret
   -fno-ghci-history
   -fimplicit-import-qualified
   -fshow-warning-groups
@@ -34,6 +36,7 @@ with the following modifiers:
   -XNondecreasingIndentation
 GHCi-specific dynamic flag settings:
 other dynamic, non-language, flag settings:
+  -fno-diagnostics-show-caret
   -fno-ghci-history
   -fimplicit-import-qualified
   -fshow-warning-groups
@@ -50,6 +53,7 @@ with the following modifiers:
   -XNondecreasingIndentation
 GHCi-specific dynamic flag settings:
 other dynamic, non-language, flag settings:
+  -fno-diagnostics-show-caret
   -fno-ghci-history
   -fimplicit-import-qualified
   -fshow-warning-groups
diff --git a/testsuite/tests/ghci/scripts/ghci024.stdout b/testsuite/tests/ghci/scripts/ghci024.stdout
index e224d806c7..978b6f9205 100644
--- a/testsuite/tests/ghci/scripts/ghci024.stdout
+++ b/testsuite/tests/ghci/scripts/ghci024.stdout
@@ -6,6 +6,7 @@ with the following modifiers:
   -XNondecreasingIndentation
 GHCi-specific dynamic flag settings:
 other dynamic, non-language, flag settings:
+  -fno-diagnostics-show-caret
   -fno-ghci-history
   -fimplicit-import-qualified
   -fshow-warning-groups
diff --git a/testsuite/tests/ghci/scripts/ghci057.stdout b/testsuite/tests/ghci/scripts/ghci057.stdout
index 02ee22c7e8..b2de5417a2 100644
--- a/testsuite/tests/ghci/scripts/ghci057.stdout
+++ b/testsuite/tests/ghci/scripts/ghci057.stdout
@@ -5,6 +5,7 @@ with the following modifiers:
   -XNondecreasingIndentation
 GHCi-specific dynamic flag settings:
 other dynamic, non-language, flag settings:
+  -fno-diagnostics-show-caret
   -fno-ghci-history
   -fimplicit-import-qualified
   -fshow-warning-groups
@@ -20,6 +21,7 @@ with the following modifiers:
   -XNondecreasingIndentation
 GHCi-specific dynamic flag settings:
 other dynamic, non-language, flag settings:
+  -fno-diagnostics-show-caret
   -fno-ghci-history
   -fimplicit-import-qualified
   -fshow-warning-groups
@@ -34,6 +36,7 @@ with the following modifiers:
   -XNondecreasingIndentation
 GHCi-specific dynamic flag settings:
 other dynamic, non-language, flag settings:
+  -fno-diagnostics-show-caret
   -fno-ghci-history
   -fimplicit-import-qualified
   -fshow-warning-groups
@@ -50,6 +53,7 @@ with the following modifiers:
   -XNondecreasingIndentation
 GHCi-specific dynamic flag settings:
 other dynamic, non-language, flag settings:
+  -fno-diagnostics-show-caret
   -fno-ghci-history
   -fimplicit-import-qualified
   -fshow-warning-groups
diff --git a/testsuite/tests/warnings/should_fail/CaretDiagnostics1.hs b/testsuite/tests/warnings/should_fail/CaretDiagnostics1.hs
new file mode 100644
index 0000000000..6ecadf690c
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/CaretDiagnostics1.hs
@@ -0,0 +1,17 @@
+module CaretDiagnostics1 where
+
+main :: IO ()
+main = do
+  10000000000000000000000000000000000000 +
+    2 +
+      (3 :: Int)
+  pure ("this is not an IO" + (            ))
+
+  where
+
+    _ = case id of
+      "γηξ" -> (
+        ) '0'
+
+fóo :: Int
+fóo = ()
diff --git a/testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr b/testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr
new file mode 100644
index 0000000000..68fbfa7714
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr
@@ -0,0 +1,72 @@
+
+CaretDiagnostics1.hs:(5,3)-(7,16): error:
+    • Couldn't match expected type ‘IO a1’ with actual type ‘Int’
+    • In a stmt of a 'do' block:
+        10000000000000000000000000000000000000 + 2 + (3 :: Int)
+      In the expression:
+        do 10000000000000000000000000000000000000 + 2 + (3 :: Int)
+           pure ("this is not an IO" + ())
+      In an equation for ‘main’:
+          main
+            = do 10000000000000000000000000000000000000 + 2 + (3 :: Int)
+                 pure ("this is not an IO" + ())
+            where
+                _ = case id of { "γηξ" -> () '0' }
+  |
+5 |   10000000000000000000000000000000000000 +
+  |   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...
+
+CaretDiagnostics1.hs:8:3-45: error:
+    • Couldn't match type ‘[Char]’ with ‘()’
+      Expected type: IO ()
+        Actual type: IO [Char]
+    • In a stmt of a 'do' block: pure ("this is not an IO" + ())
+      In the expression:
+        do 10000000000000000000000000000000000000 + 2 + (3 :: Int)
+           pure ("this is not an IO" + ())
+      In an equation for ‘main’:
+          main
+            = do 10000000000000000000000000000000000000 + 2 + (3 :: Int)
+                 pure ("this is not an IO" + ())
+            where
+                _ = case id of { "γηξ" -> () '0' }
+  |
+8 |   pure ("this is not an IO" + (            ))
+  |   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+CaretDiagnostics1.hs:8:31-44: error:
+    • Couldn't match expected type ‘[Char]’ with actual type ‘()’
+    • In the second argument of ‘(+)’, namely ‘()’
+      In the first argument of ‘pure’, namely
+        ‘("this is not an IO" + ())’
+      In a stmt of a 'do' block: pure ("this is not an IO" + ())
+  |
+8 |   pure ("this is not an IO" + (            ))
+  |                               ^^^^^^^^^^^^^^
+
+CaretDiagnostics1.hs:13:7-11: error:
+    • Couldn't match expected type ‘a0 -> a0’ with actual type ‘[Char]’
+    • In the pattern: "γηξ"
+      In a case alternative: "γηξ" -> () '0'
+      In the expression: case id of { "γηξ" -> () '0' }
+   |
+13 |       "γηξ" -> (
+   |       ^^^^^
+
+CaretDiagnostics1.hs:(13,16)-(14,13): error:
+    • Couldn't match expected type ‘Char -> p0’ with actual type ‘()’
+    • The function ‘()’ is applied to one argument,
+      but its type ‘()’ has none
+      In the expression: () '0'
+      In a case alternative: "γηξ" -> () '0'
+   |
+13 |       "γηξ" -> (
+   |                ^...
+
+CaretDiagnostics1.hs:17:7-8: error:
+    • Couldn't match expected type ‘Int’ with actual type ‘()’
+    • In the expression: ()
+      In an equation for ‘fóo’: fóo = ()
+   |
+17 | fóo = ()
+   |       ^^
diff --git a/testsuite/tests/warnings/should_fail/CaretDiagnostics2.hs b/testsuite/tests/warnings/should_fail/CaretDiagnostics2.hs
new file mode 100644
index 0000000000..05548666ff
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/CaretDiagnostics2.hs
@@ -0,0 +1,3 @@
+module CaretDiagnostics2 where
+
+Ó&lËå5kÍ
diff --git a/testsuite/tests/warnings/should_fail/CaretDiagnostics2.stderr b/testsuite/tests/warnings/should_fail/CaretDiagnostics2.stderr
new file mode 100644
index 0000000000..713f9246a5
--- /dev/null
+++ b/testsuite/tests/warnings/should_fail/CaretDiagnostics2.stderr
@@ -0,0 +1,6 @@
+
+CaretDiagnostics2.hs:3:1: error:
+    lexical error (UTF-8 decoding error)
+  |
+3 | �&l��5k�
+  | ^
diff --git a/testsuite/tests/warnings/should_fail/all.T b/testsuite/tests/warnings/should_fail/all.T
index 3522bb275f..71a7a97157 100644
--- a/testsuite/tests/warnings/should_fail/all.T
+++ b/testsuite/tests/warnings/should_fail/all.T
@@ -1 +1,3 @@
 test('WerrorFail', normal, compile_fail, [''])
+test('CaretDiagnostics1', normal, compile_fail, ['-fdiagnostics-show-caret -ferror-spans'])
+test('CaretDiagnostics2', normal, compile_fail, ['-fdiagnostics-show-caret'])