From 19328a8c38a4d55af7d35fcd16debe2e8b474781 Mon Sep 17 00:00:00 2001
From: Xiaoyan Ren <xy.r@outlook.com>
Date: Tue, 26 Dec 2023 18:35:46 +0800
Subject: [PATCH] Do not color the diagnostic code in error messages (#24172)

---
 compiler/GHC/Types/Error.hs                        | 2 +-
 testsuite/tests/ghc-e/should_fail/T24172.hs        | 1 +
 testsuite/tests/ghc-e/should_fail/T24172.stderr    | 8 ++++++++
 testsuite/tests/ghc-e/should_fail/all.T            | 2 ++
 testsuite/tests/warnings/should_fail/Colour.stderr | 2 +-
 5 files changed, 13 insertions(+), 2 deletions(-)
 create mode 100644 testsuite/tests/ghc-e/should_fail/T24172.hs
 create mode 100644 testsuite/tests/ghc-e/should_fail/T24172.stderr

diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index ef94dd212520..a0306db5592a 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -659,7 +659,7 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
 
           code_doc =
             case msg_class of
-              MCDiagnostic _ _ (Just code) -> brackets (coloured msg_colour $ ppr_with_hyperlink code)
+              MCDiagnostic _ _ (Just code) -> brackets (ppr_with_hyperlink code)
               _                            -> empty
 
           flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc
diff --git a/testsuite/tests/ghc-e/should_fail/T24172.hs b/testsuite/tests/ghc-e/should_fail/T24172.hs
new file mode 100644
index 000000000000..30a889a09b5a
--- /dev/null
+++ b/testsuite/tests/ghc-e/should_fail/T24172.hs
@@ -0,0 +1 @@
+main = print $ 1 + Bool
diff --git a/testsuite/tests/ghc-e/should_fail/T24172.stderr b/testsuite/tests/ghc-e/should_fail/T24172.stderr
new file mode 100644
index 000000000000..83ec6c2a5bca
--- /dev/null
+++ b/testsuite/tests/ghc-e/should_fail/T24172.stderr
@@ -0,0 +1,8 @@
+
+T24172.hs:1:20: error: [GHC-01928]
+    • Illegal term-level use of the type constructor ‘Bool’
+    • imported from ‘Prelude’ at T24172.hs:1:1
+      (and originally defined in ‘GHC.Types’)
+    • In the second argument of ‘(+)’, namely ‘Bool’
+      In the second argument of ‘($)’, namely ‘1 + Bool’
+      In the expression: print $ 1 + Bool
diff --git a/testsuite/tests/ghc-e/should_fail/all.T b/testsuite/tests/ghc-e/should_fail/all.T
index f4840f968578..0a1f262d681c 100644
--- a/testsuite/tests/ghc-e/should_fail/all.T
+++ b/testsuite/tests/ghc-e/should_fail/all.T
@@ -56,3 +56,5 @@ test('T18441fail18', req_interp, makefile_test, ['T18441fail18'])
 test('T18441fail19', [ignore_stderr, exit_code(1)], run_command, ['{compiler} -e ":cd abcd"'])
 
 test('T23663', req_interp, makefile_test, ['T23663'])
+
+test('T24172', normal, compile_fail, ['-fdiagnostics-color=always'])
diff --git a/testsuite/tests/warnings/should_fail/Colour.stderr b/testsuite/tests/warnings/should_fail/Colour.stderr
index 79b3ef96833d..a389680cd69f 100644
--- a/testsuite/tests/warnings/should_fail/Colour.stderr
+++ b/testsuite/tests/warnings/should_fail/Colour.stderr
@@ -1,5 +1,5 @@
 
-Colour.hs:1:8: error: [GHC-83865]
+Colour.hs:1:8: error: [GHC-83865]
     • Couldn't match expected type ‘IO ()’ with actual type ‘()’
     • In the expression: () :: IO ()
       In an equation for ‘main’: main = () :: IO ()
-- 
GitLab