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

16 files changed, 228 insertions, 14 deletions

diff --git a/.arc-linters/check-binaries.py b/.arc-linters/check-binaries.py
index 9125985489..85227eaa4e 100755
--- a/.arc-linters/check-binaries.py
+++ b/.arc-linters/check-binaries.py
@@ -9,8 +9,8 @@ import json
 path = sys.argv[1]
 warnings = []
 if os.path.isfile(path):
-    with open(path) as f:
-        if '\0' in f.read(8000):
+    with open(path, 'rb') as f:
+        if b'\0' in f.read(8000):
             warning = {
                 'severity': 'warning',
                 'message': 'This file appears to be a binary file; does it really belong in the repository?'
diff --git a/.arc-linters/check-cpp.py b/.arc-linters/check-cpp.py
index 52961e6edd..f9d0552b00 100755
--- a/.arc-linters/check-cpp.py
+++ b/.arc-linters/check-cpp.py
@@ -25,9 +25,9 @@ logger.debug(sys.argv)
 
 path = sys.argv[1]
 warnings = []
-r = re.compile(r'ASSERT\s+\(')
+r = re.compile(rb'ASSERT\s+\(')
 if os.path.isfile(path):
-    with open(path) as f:
+    with open(path, 'rb') as f:
         for lineno, line in enumerate(f):
             if r.search(line):
                 warning = {
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 6ecf8ca9a9..e7ace47f2a 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -176,7 +176,8 @@ import FastString
 import Outputable
 import Foreign.C        ( CInt(..) )
 import System.IO.Unsafe ( unsafeDupablePerformIO )
-import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn )
+import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn
+                               , getCaretDiagnostic )
 import SysTools.Terminal ( stderrSupportsAnsiColors )
 
 import System.IO.Unsafe ( unsafePerformIO )
@@ -517,6 +518,7 @@ data GeneralFlag
    -- output style opts
    | Opt_ErrorSpans -- Include full span info in error messages,
                     -- instead of just the start position.
+   | Opt_DiagnosticsShowCaret -- Show snippets of offending code
    | Opt_PprCaseAsLet
    | Opt_PprShowTicks
    | Opt_ShowHoleConstraints
@@ -1699,8 +1701,14 @@ defaultLogAction dflags reason severity srcSpan style msg
       SevInteractive -> putStrSDoc msg style
       SevInfo        -> printErrs msg style
       SevFatal       -> printErrs msg style
-      _              -> do hPutChar stderr '\n'
-                           printErrs message (setStyleColoured True style)
+      _              -> do -- otherwise (i.e. SevError or SevWarning)
+                           hPutChar stderr '\n'
+                           caretDiagnostic <-
+                               if gopt Opt_DiagnosticsShowCaret dflags
+                               then getCaretDiagnostic severity srcSpan
+                               else pure empty
+                           printErrs (message $+$ caretDiagnostic)
+                               (setStyleColoured True style)
                            -- careful (#2302): printErrs prints in UTF-8,
                            -- whereas converting to string first and using
                            -- hPutStr would just emit the low 8 bits of
@@ -3477,6 +3485,7 @@ fFlagsDeps = [
   flagSpec "defer-type-errors"                Opt_DeferTypeErrors,
   flagSpec "defer-typed-holes"                Opt_DeferTypedHoles,
   flagSpec "defer-out-of-scope-variables"     Opt_DeferOutOfScopeVariables,
+  flagSpec "diagnostics-show-caret"           Opt_DiagnosticsShowCaret,
   flagSpec "dicts-cheap"                      Opt_DictsCheap,
   flagSpec "dicts-strict"                     Opt_DictsStrict,
   flagSpec "dmd-tx-dict-sel"                  Opt_DmdTxDictSel,
@@ -3780,6 +3789,7 @@ defaultFlags :: Settings -> [GeneralFlag]
 defaultFlags settings
 -- See Note [Updating flag description in the User's Guide]
   = [ Opt_AutoLinkPackages,
+      Opt_DiagnosticsShowCaret,
       Opt_EmbedManifest,
       Opt_FlatCache,
       Opt_GenManifest,
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 0f478ef28b..c410f06099 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -35,6 +35,7 @@ module ErrUtils (
 
         -- * Utilities
         doIfSet, doIfSet_dyn,
+        getCaretDiagnostic,
 
         -- * Dump files
         dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
@@ -60,6 +61,8 @@ import Outputable
 import Panic
 import SrcLoc
 import DynFlags
+import FastString (unpackFS)
+import StringBuffer (hGetStringBuffer, len, lexemeToString)
 
 import System.Directory
 import System.Exit      ( ExitCode(..), exitWith )
@@ -74,6 +77,7 @@ import Data.Time
 import Control.Monad
 import Control.Monad.IO.Class
 import System.IO
+import System.IO.Error  ( catchIOError )
 import GHC.Conc         ( getAllocationCounter )
 import System.CPUTime
 
@@ -190,20 +194,99 @@ mkLocMessageAnn ann severity locn msg
           -- Add prefixes, like    Foo.hs:34: warning:
           --                           <the warning message>
           prefix = locn' <> colon <+>
-                   coloured (colBold `mappend` sevColor) sevText <> optAnn
+                   coloured sevColour sevText <> optAnn
       in bold (hang prefix 4 msg)
   where
-    (sevText, sevColor) =
+    sevColour = colBold `mappend` getSeverityColour severity
+
+    sevText =
       case severity of
-        SevWarning -> (text "warning:", colMagentaFg)
-        SevError   -> (text "error:", colRedFg)
-        SevFatal   -> (text "fatal:", colRedFg)
-        _          -> (empty, mempty)
+        SevWarning -> text "warning:"
+        SevError   -> text "error:"
+        SevFatal   -> text "fatal:"
+        _          -> empty
 
     -- Add optional information
     optAnn = case ann of
       Nothing -> text ""
-      Just i  -> text " [" <> coloured sevColor (text i) <> text "]"
+      Just i  -> text " [" <> coloured sevColour (text i) <> text "]"
+
+getSeverityColour :: Severity -> PprColour
+getSeverityColour SevWarning = colMagentaFg
+getSeverityColour SevError   = colRedFg
+getSeverityColour SevFatal   = colRedFg
+getSeverityColour _          = mempty
+
+getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
+getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
+getCaretDiagnostic severity (RealSrcSpan span) = do
+  caretDiagnostic <$> getSrcLine (srcSpanFile span) (row - 1)
+
+  where
+
+    getSrcLine fn i = do
+      (getLine i <$> readFile' (unpackFS fn))
+        `catchIOError` \ _ ->
+          pure Nothing
+
+    getLine i contents =
+      case drop i (lines contents) of
+        srcLine : _ -> Just srcLine
+        [] -> Nothing
+
+    readFile' fn = do
+      -- StringBuffer has advantages over readFile:
+      -- (a) no lazy IO, otherwise IO exceptions may occur in pure code
+      -- (b) always UTF-8, rather than some system-dependent encoding
+      --     (Haskell source code must be UTF-8 anyway)
+      buf <- hGetStringBuffer fn
+      pure (fix <$> lexemeToString buf (len buf))
+
+    -- allow user to visibly see that their code is incorrectly encoded
+    -- (StringBuffer.nextChar uses \0 to represent undecodable characters)
+    fix '\0' = '\xfffd'
+    fix c    = c
+
+    sevColour = colBold `mappend` getSeverityColour severity
+
+    marginColour = colBold `mappend` colBlueFg
+
+    row = srcSpanStartLine span
+    rowStr = show row
+    multiline = row /= srcSpanEndLine span
+
+    stripNewlines = filter (/= '\n')
+
+    caretDiagnostic Nothing = empty
+    caretDiagnostic (Just srcLineWithNewline) =
+      coloured marginColour (text marginSpace) <>
+      text ("\n") <>
+      coloured marginColour (text marginRow) <>
+      text (" " ++ srcLinePre) <>
+      coloured sevColour (text srcLineSpan) <>
+      text (srcLinePost ++ "\n") <>
+      coloured marginColour (text marginSpace) <>
+      coloured sevColour (text (" " ++ caretLine))
+
+      where
+
+        srcLine = stripNewlines srcLineWithNewline
+
+        start = srcSpanStartCol span - 1
+        end | multiline = length srcLine
+            | otherwise = srcSpanEndCol span - 1
+        width = max 1 (end - start)
+
+        marginWidth = length rowStr
+        marginSpace = replicate marginWidth ' ' ++ " |"
+        marginRow   = rowStr ++ " |"
+
+        (srcLinePre,  srcLineRest) = splitAt start srcLine
+        (srcLineSpan, srcLinePost) = splitAt width srcLineRest
+
+        caretEllipsis | multiline = "..."
+                      | otherwise = ""
+        caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
 
 makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
 makeIntoWarning reason err = err
diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot
index b991ec4958..f6ce45395d 100644
--- a/compiler/main/ErrUtils.hs-boot
+++ b/compiler/main/ErrUtils.hs-boot
@@ -17,3 +17,4 @@ type MsgDoc = SDoc
 
 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
 mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
+getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index 460201eb92..7b01fc27b6 100644
--- a/docs/users_guide/using.rst
+++ b/docs/users_guide/using.rst
@@ -800,6 +800,12 @@ messages and in GHCi:
     the detection mechanism is not yet implemented, so colors are off by
     default on all platforms.)
 
+.. ghc-flag:: -f[no-]diagnostics-show-caret
+
+    Controls whether GHC displays a line of the original source code where the
+    error was detected.  This also affects the associated caret symbol that
+    points at the region of code at fault.  The flag is on by default.
+
 .. ghc-flag:: -ferror-spans
 
     Causes GHC to emit the full source span of the syntactic entity
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'])
diff --git a/utils/mkUserGuidePart/Options/Verbosity.hs b/utils/mkUserGuidePart/Options/Verbosity.hs
index c67fa74b8b..ff1e5a9a90 100644
--- a/utils/mkUserGuidePart/Options/Verbosity.hs
+++ b/utils/mkUserGuidePart/Options/Verbosity.hs
@@ -68,6 +68,10 @@ verbosityOptions =
          , flagDescription = "Use colors in error messages"
          , flagType = DynamicFlag
          }
+  , flag { flagName = "-f[no-]diagnostics-show-caret"
+         , flagDescription = "Whether to show snippets of original source code"
+         , flagType = DynamicFlag
+         }
   , flag { flagName = "-ferror-spans"
          , flagDescription = "Output full span in error messages"
          , flagType = DynamicFlag