[commit: ghc] master: Render \t as 8 spaces in caret diagnostics (c068c38)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/c068c38727b7bd7a1a75495167f7470abb7bf866/ghc

>---------------------------------------------------------------

commit c068c38727b7bd7a1a75495167f7470abb7bf866
Author: Phil Ruffwind <rf at rufflewind.com>
Date:   Thu May 11 15:41:08 2017 -0400

    Render \t as 8 spaces in caret diagnostics
    
    Test Plan: validate
    
    Reviewers: austin, bgamari, rwbarton
    
    Reviewed By: bgamari
    
    Subscribers: rwbarton, thomie
    
    GHC Trac Issues: #13664
    
    Differential Revision: https://phabricator.haskell.org/D3549


>---------------------------------------------------------------

c068c38727b7bd7a1a75495167f7470abb7bf866
 compiler/main/ErrUtils.hs                                 | 10 +++++++---
 testsuite/driver/testlib.py                               | 14 ++++++++++++--
 testsuite/tests/warnings/should_fail/CaretDiagnostics1.hs |  3 +++
 .../tests/warnings/should_fail/CaretDiagnostics1.stderr   |  8 ++++++++
 testsuite/tests/warnings/should_fail/all.T                | 15 ++++++++++++++-
 5 files changed, 44 insertions(+), 6 deletions(-)

diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index ded7085..d87d2b2 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -261,8 +261,6 @@ getCaretDiagnostic severity (RealSrcSpan span) = do
     rowStr = show row
     multiline = row /= srcSpanEndLine span
 
-    stripNewlines = filter (/= '\n')
-
     caretDiagnostic Nothing = empty
     caretDiagnostic (Just srcLineWithNewline) =
       sdocWithDynFlags $ \ dflags ->
@@ -280,7 +278,13 @@ getCaretDiagnostic severity (RealSrcSpan span) = do
 
       where
 
-        srcLine = stripNewlines srcLineWithNewline
+        fixWhitespace (i, c)
+          | c == '\n' = ""
+            -- show tabs in a device-independent manner #13664
+          | c == '\t' = replicate (8 - i `mod` 8) ' '
+          | otherwise = [c]
+
+        srcLine = concat (map fixWhitespace (zip [0..] srcLineWithNewline))
 
         start = srcSpanStartCol span - 1
         end | multiline = length srcLine
diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py
index 1f08f5b..b730685 100644
--- a/testsuite/driver/testlib.py
+++ b/testsuite/driver/testlib.py
@@ -84,6 +84,8 @@ def setTestOpts( f ):
 #      test('test001', expect_fail, compile, [''])
 #
 # to expect failure for this test.
+#
+# type TestOpt = (name :: String, opts :: Object) -> IO ()
 
 def normal( name, opts ):
     return;
@@ -518,6 +520,12 @@ def normalise_errmsg_fun( *fs ):
 def _normalise_errmsg_fun( name, opts, *fs ):
     opts.extra_errmsg_normaliser =  join_normalisers(opts.extra_errmsg_normaliser, fs)
 
+def normalise_whitespace_fun(f):
+    return lambda name, opts: _normalise_whitespace_fun(name, opts, f)
+
+def _normalise_whitespace_fun(name, opts, f):
+    opts.whitespace_normaliser = f
+
 def normalise_version_( *pkgs ):
     def normalise_version__( str ):
         return re.sub('(' + '|'.join(map(re.escape,pkgs)) + ')-[0-9.]+',
@@ -622,7 +630,7 @@ def runTest(watcher, opts, name, func, args):
         test_common_work(watcher, name, opts, func, args)
 
 # name  :: String
-# setup :: TestOpts -> IO ()
+# setup :: [TestOpt] -> IO ()
 def test(name, setup, func, args):
     global aloneTests
     global parallelTests
@@ -1006,7 +1014,9 @@ def do_compile(name, way, should_fail, top_mod, extra_mods, extra_hc_opts, **kwa
                            join_normalisers(getTestOpts().extra_errmsg_normaliser,
                                             normalise_errmsg),
                            expected_stderr_file, actual_stderr_file,
-                           whitespace_normaliser=normalise_whitespace):
+                           whitespace_normaliser=getattr(getTestOpts(),
+                                                         "whitespace_normaliser",
+                                                         normalise_whitespace)):
         return failBecause('stderr mismatch')
 
     # no problems found, this test passed
diff --git a/testsuite/tests/warnings/should_fail/CaretDiagnostics1.hs b/testsuite/tests/warnings/should_fail/CaretDiagnostics1.hs
index 6ecadf6..3ebb5ee 100644
--- a/testsuite/tests/warnings/should_fail/CaretDiagnostics1.hs
+++ b/testsuite/tests/warnings/should_fail/CaretDiagnostics1.hs
@@ -15,3 +15,6 @@ main = do
 
 fóo :: Int
 fóo = ()
+
+tabby :: Int
+tabby =  	()
diff --git a/testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr b/testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr
index 68fbfa7..600b7c7 100644
--- a/testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr
+++ b/testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr
@@ -70,3 +70,11 @@ CaretDiagnostics1.hs:17:7-8: error:
    |
 17 | fóo = ()
    |       ^^
+
+CaretDiagnostics1.hs:20:17-18: error:
+    • Couldn't match expected type ‘Int’ with actual type ‘()’
+    • In the expression: ()
+      In an equation for ‘tabby’: tabby = ()
+   |
+20 | tabby =         ()
+   |                 ^^
diff --git a/testsuite/tests/warnings/should_fail/all.T b/testsuite/tests/warnings/should_fail/all.T
index 71a7a97..73117a9 100644
--- a/testsuite/tests/warnings/should_fail/all.T
+++ b/testsuite/tests/warnings/should_fail/all.T
@@ -1,3 +1,16 @@
+import re
+
+def normalise_whitespace_carefully(s):
+    # Merge contiguous whitespace characters into a single space
+    # except on caret diagnostic lines
+    return '\n'.join(line
+                     if re.match(r'\s*\d*\s*\|', line)
+                     else ' '.join(w for w in line.split())
+                     for line in s.split('\n'))
+
 test('WerrorFail', normal, compile_fail, [''])
-test('CaretDiagnostics1', normal, compile_fail, ['-fdiagnostics-show-caret -ferror-spans'])
+test('CaretDiagnostics1',
+     [normalise_whitespace_fun(normalise_whitespace_carefully)],
+     compile_fail,
+     ['-fdiagnostics-show-caret -ferror-spans'])
 test('CaretDiagnostics2', normal, compile_fail, ['-fdiagnostics-show-caret'])