From 86d2971e3cf194d23b483a7cd9466d928e104ca5 Mon Sep 17 00:00:00 2001
From: doyougnu <jeffrey.young@iohk.io>
Date: Sun, 7 May 2023 16:16:56 -0400
Subject: [PATCH] compiler,ghci: error codes link to HF error index
closes: #23259
- adds -fprint-error-index-links={auto|always|never} flag
---
compiler/GHC/Driver/DynFlags.hs | 9 ++++--
compiler/GHC/Driver/Session.hs | 7 +++++
compiler/GHC/Types/Error.hs | 29 ++++++++++++++++++-
compiler/GHC/Utils/Outputable.hs | 2 ++
.../expected-undocumented-flags.txt | 3 ++
docs/users_guide/using.rst | 14 +++++++++
hadrian/src/Rules/Test.hs | 2 +-
hadrian/src/Settings/Builders/RunTest.hs | 2 +-
testsuite/mk/test.mk | 3 ++
.../ghc-api/target-contents/TargetContents.hs | 1 +
.../should_fail/GHCiErrorIndexLinks.script | 1 +
.../should_fail/GHCiErrorIndexLinks.stderr | 6 ++++
testsuite/tests/ghci/should_fail/all.T | 1 +
testsuite/tests/runghc/Makefile | 2 +-
.../typecheck/should_fail/ErrorIndexLinks.hs | 7 +++++
.../should_fail/ErrorIndexLinks.stderr | 7 +++++
testsuite/tests/typecheck/should_fail/all.T | 1 +
17 files changed, 91 insertions(+), 6 deletions(-)
create mode 100644 testsuite/tests/ghci/should_fail/GHCiErrorIndexLinks.script
create mode 100644 testsuite/tests/ghci/should_fail/GHCiErrorIndexLinks.stderr
create mode 100644 testsuite/tests/typecheck/should_fail/ErrorIndexLinks.hs
create mode 100644 testsuite/tests/typecheck/should_fail/ErrorIndexLinks.stderr
diff --git a/compiler/GHC/Driver/DynFlags.hs b/compiler/GHC/Driver/DynFlags.hs
index a9e89ffac835..026a953cfd43 100644
--- a/compiler/GHC/Driver/DynFlags.hs
+++ b/compiler/GHC/Driver/DynFlags.hs
@@ -413,6 +413,8 @@ data DynFlags = DynFlags {
useUnicode :: Bool,
useColor :: OverridingBool,
canUseColor :: Bool,
+ useErrorLinks :: OverridingBool,
+ canUseErrorLinks :: Bool,
colScheme :: Col.Scheme,
-- | what kind of {-# SCC #-} to add automatically
@@ -513,6 +515,8 @@ initDynFlags dflags = do
useUnicode = useUnicode',
useColor = useColor',
canUseColor = stderrSupportsAnsiColors,
+ -- if the terminal supports color, we assume it supports links as well
+ canUseErrorLinks = stderrSupportsAnsiColors,
colScheme = colScheme',
tmpDir = TempDir tmp_dir
}
@@ -679,6 +683,8 @@ defaultDynFlags mySettings =
useUnicode = False,
useColor = Auto,
canUseColor = False,
+ useErrorLinks = Auto,
+ canUseErrorLinks = False,
colScheme = Col.defaultScheme,
profAuto = NoProfAuto,
callerCcFilters = [],
@@ -1191,7 +1197,6 @@ defaultFlags settings
-- Default floating flags (see Note [RHS Floating])
++ [ Opt_LocalFloatOut, Opt_LocalFloatOutTopLevel ]
-
++ default_PIC platform
++ validHoleFitDefaults
@@ -1479,7 +1484,6 @@ versionedFilePath platform = uniqueSubdir platform
-- SDoc
-------------------------------------------
-
-- | Initialize the pretty-printing options
initSDocContext :: DynFlags -> PprStyle -> SDocContext
initSDocContext dflags style = SDC
@@ -1490,6 +1494,7 @@ initSDocContext dflags style = SDC
, sdocDefaultDepth = pprUserLength dflags
, sdocLineLength = pprCols dflags
, sdocCanUseUnicode = useUnicode dflags
+ , sdocPrintErrIndexLinks = overrideWith (canUseErrorLinks dflags) (useErrorLinks dflags)
, sdocHexWordLiterals = gopt Opt_HexWordLiterals dflags
, sdocPprDebug = dopt Opt_D_ppr_debug dflags
, sdocPrintUnicodeSyntax = gopt Opt_PrintUnicodeSyntax dflags
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 8cc82e9fc5d5..8994200b4aa5 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -1314,6 +1314,13 @@ dynamic_flags_deps = [
, make_ord_flag defFlag "fdiagnostics-color=never"
(NoArg (upd (\d -> d { useColor = Never })))
+ , make_ord_flag defFlag "fprint-error-index-links=auto"
+ (NoArg (upd (\d -> d { useErrorLinks = Auto })))
+ , make_ord_flag defFlag "fprint-error-index-links=always"
+ (NoArg (upd (\d -> d { useErrorLinks = Always })))
+ , make_ord_flag defFlag "fprint-error-index-links=never"
+ (NoArg (upd (\d -> d { useErrorLinks = Never })))
+
-- Suppress all that is suppressible in core dumps.
-- Except for uniques, as some simplifier phases introduce new variables that
-- have otherwise identical names.
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index 0f67dc0ff53a..2cdc2826ea79 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -603,9 +603,18 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg
-> brackets msg
_ -> empty
+ ppr_with_hyperlink code =
+ -- this is a bit hacky, but we assume that if the terminal supports colors
+ -- then it should also support links
+ sdocOption (\ ctx -> sdocPrintErrIndexLinks ctx) $
+ \ use_hyperlinks ->
+ if use_hyperlinks
+ then ppr $ LinkedDiagCode code
+ else ppr code
+
code_doc =
case msg_class of
- MCDiagnostic _ _ (Just code) -> brackets (coloured msg_colour $ ppr code)
+ MCDiagnostic _ _ (Just code) -> brackets (coloured msg_colour $ ppr_with_hyperlink code)
_ -> empty
flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc
@@ -813,5 +822,23 @@ instance Show DiagnosticCode where
show (DiagnosticCode prefix c) =
prefix ++ "-" ++ printf "%05d" c
-- pad the numeric code to have at least 5 digits
+
instance Outputable DiagnosticCode where
ppr code = text (show code)
+
+-- | A newtype that is a witness to the `-fprint-error-index-links` flag. It
+-- alters the @Outputable@ instance to emit @DiagnosticCode@ as ANSI hyperlinks
+-- to the HF error index
+newtype LinkedDiagCode = LinkedDiagCode DiagnosticCode
+
+instance Outputable LinkedDiagCode where
+ ppr (LinkedDiagCode d@DiagnosticCode{}) = linkEscapeCode d
+
+-- | Wrap the link in terminal escape codes specified by OSC 8.
+linkEscapeCode :: DiagnosticCode -> SDoc
+linkEscapeCode d = text "\ESC]8;;" <> hfErrorLink d -- make the actual link
+ <> text "\ESC\\" <> ppr d <> text "\ESC]8;;\ESC\\" -- the rest is the visible text
+
+-- | create a link to the HF error index given an error code.
+hfErrorLink :: DiagnosticCode -> SDoc
+hfErrorLink errorCode = text "https://errors.haskell.org/messages/" <> ppr errorCode
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 4bc32a940d81..e08b61915c7f 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -396,6 +396,7 @@ data SDocContext = SDC
, sdocCanUseUnicode :: !Bool
-- ^ True if Unicode encoding is supported
-- and not disabled by GHC_NO_UNICODE environment variable
+ , sdocPrintErrIndexLinks :: !Bool
, sdocHexWordLiterals :: !Bool
, sdocPprDebug :: !Bool
, sdocPrintUnicodeSyntax :: !Bool
@@ -457,6 +458,7 @@ defaultSDocContext = SDC
, sdocDefaultDepth = 5
, sdocLineLength = 100
, sdocCanUseUnicode = False
+ , sdocPrintErrIndexLinks = False
, sdocHexWordLiterals = False
, sdocPprDebug = False
, sdocPrintUnicodeSyntax = False
diff --git a/docs/users_guide/expected-undocumented-flags.txt b/docs/users_guide/expected-undocumented-flags.txt
index 6fa3f2f27da7..b6ad2f817c73 100644
--- a/docs/users_guide/expected-undocumented-flags.txt
+++ b/docs/users_guide/expected-undocumented-flags.txt
@@ -41,6 +41,9 @@
-fdiagnostics-color=always
-fdiagnostics-color=auto
-fdiagnostics-color=never
+-fprint-error-index-links=always
+-fprint-error-index-links=auto
+-fprint-error-index-links=never
-fembed-manifest
-fextended-default-rules
-ffast-pap-calls
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index de9d7674ed3b..ebc3fe06722f 100644
--- a/docs/users_guide/using.rst
+++ b/docs/users_guide/using.rst
@@ -1470,6 +1470,20 @@ messages and in GHCi:
error occurred. This controls whether the part of the error message which
says "In the equation..", "In the pattern.." etc is displayed or not.
+.. ghc-flag:: -fprint-error-index-links=⟨always|auto|never⟩
+ :shortdesc: Whether to emit diagnostic codes as ANSI hyperlinks to the
+ Haskell Error Index.
+ :type: dynamic
+ :category: verbosity
+
+ :default: auto
+
+ Controls whether GHC will emit error indices as ANSI hyperlinks to the
+ `Haskell Error Index <https://errors.haskell.org/>`_. When set to auto, this
+ flag will render hyperlinks if the terminal is capable; when set to always,
+ this flag will render the hyperlinks regardless of the capabilities of the
+ terminal.
+
.. ghc-flag:: -ferror-spans
:shortdesc: Output full span in error messages
:type: dynamic
diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
index 8366e5a23704..9aefe783bb49 100644
--- a/hadrian/src/Rules/Test.hs
+++ b/hadrian/src/Rules/Test.hs
@@ -244,7 +244,7 @@ testRules = do
ghcFlags <- runTestGhcFlags
let ghciFlags = ghcFlags ++ unwords
[ "--interactive", "-v0", "-ignore-dot-ghci"
- , "-fno-ghci-history"
+ , "-fno-ghci-history", "-fprint-error-index-links=never"
]
ccPath <- queryTargetTarget (Toolchain.prgPath . Toolchain.ccProgram . Toolchain.tgtCCompiler)
ccFlags <- queryTargetTarget (unwords . Toolchain.prgFlags . Toolchain.ccProgram . Toolchain.tgtCCompiler)
diff --git a/hadrian/src/Settings/Builders/RunTest.hs b/hadrian/src/Settings/Builders/RunTest.hs
index 5da05b7376d0..0d7f3330fda3 100644
--- a/hadrian/src/Settings/Builders/RunTest.hs
+++ b/hadrian/src/Settings/Builders/RunTest.hs
@@ -51,7 +51,7 @@ runTestGhcFlags = do
-- Take flags to send to the Haskell compiler from test.mk.
-- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L37
unwords <$> sequence
- [ pure " -dcore-lint -dstg-lint -dcmm-lint -no-user-package-db -fno-dump-with-ways -rtsopts"
+ [ pure " -dcore-lint -dstg-lint -dcmm-lint -no-user-package-db -fno-dump-with-ways -fprint-error-index-links=never -rtsopts"
, pure ghcOpts
, pure ghcExtraFlags
, ifMinGhcVer "711" "-fno-warn-missed-specialisations"
diff --git a/testsuite/mk/test.mk b/testsuite/mk/test.mk
index 505d73173b33..0bce7a30221f 100644
--- a/testsuite/mk/test.mk
+++ b/testsuite/mk/test.mk
@@ -50,6 +50,9 @@ TEST_HC_OPTS += -fshow-warning-groups
TEST_HC_OPTS += -fdiagnostics-color=never
TEST_HC_OPTS += -fno-diagnostics-show-caret
+# don't generate error index links for the GHC testsuite
+TEST_HC_OPTS += -fprint-error-index-links=never
+
# See #15278.
TEST_HC_OPTS += -Werror=compat
diff --git a/testsuite/tests/ghc-api/target-contents/TargetContents.hs b/testsuite/tests/ghc-api/target-contents/TargetContents.hs
index 80b865ee8688..30fbef6c4c7b 100644
--- a/testsuite/tests/ghc-api/target-contents/TargetContents.hs
+++ b/testsuite/tests/ghc-api/target-contents/TargetContents.hs
@@ -34,6 +34,7 @@ main = do
(dflags1, xs, warn) <- parseDynamicFlags logger dflags0 $ map noLoc $
[ "-outputdir", "./outdir"
, "-fno-diagnostics-show-caret"
+ , "-fprint-error-index-links=never"
] ++ args
_ <- setSessionDynFlags dflags1
diff --git a/testsuite/tests/ghci/should_fail/GHCiErrorIndexLinks.script b/testsuite/tests/ghci/should_fail/GHCiErrorIndexLinks.script
new file mode 100644
index 000000000000..ac457bd1a618
--- /dev/null
+++ b/testsuite/tests/ghci/should_fail/GHCiErrorIndexLinks.script
@@ -0,0 +1 @@
+print $ 1729 + "hello from GHCi!"
diff --git a/testsuite/tests/ghci/should_fail/GHCiErrorIndexLinks.stderr b/testsuite/tests/ghci/should_fail/GHCiErrorIndexLinks.stderr
new file mode 100644
index 000000000000..1aba424ad4ed
--- /dev/null
+++ b/testsuite/tests/ghci/should_fail/GHCiErrorIndexLinks.stderr
@@ -0,0 +1,6 @@
+
+<interactive>:1:9: error: []8;;https://errors.haskell.org/messages/GHC-39999\GHC-39999]8;;\]
+ • No instance for ‘Num String’ arising from the literal ‘1729’
+ • In the first argument of ‘(+)’, namely ‘1729’
+ In the second argument of ‘($)’, namely ‘1729 + "hello from GHCi!"’
+ In the expression: print $ 1729 + "hello from GHCi!"
diff --git a/testsuite/tests/ghci/should_fail/all.T b/testsuite/tests/ghci/should_fail/all.T
index 0320cdb79b2d..3ecd977c8864 100644
--- a/testsuite/tests/ghci/should_fail/all.T
+++ b/testsuite/tests/ghci/should_fail/all.T
@@ -6,3 +6,4 @@ test('T16287', [], ghci_script, ['T16287.script'])
test('T18052b', [], ghci_script, ['T18052b.script'])
test('T18027a', [], ghci_script, ['T18027a.script'])
test('T20214', req_interp, makefile_test, ['T20214'])
+test('GHCiErrorIndexLinks', [extra_hc_opts("-fprint-error-index-links=always")], ghci_script, ['GHCiErrorIndexLinks.script'])
diff --git a/testsuite/tests/runghc/Makefile b/testsuite/tests/runghc/Makefile
index 5823471ad4ca..a05a6ce54e69 100644
--- a/testsuite/tests/runghc/Makefile
+++ b/testsuite/tests/runghc/Makefile
@@ -26,7 +26,7 @@ T11247:
T17171a:
'$(RUNGHC)' --ghc-arg=-Wall T17171a.hs
T17171b:
- '$(RUNGHC)' --ghc-arg=-Wall T17171b.hs
+ '$(RUNGHC)' --ghc-arg=-Wall -fprint-error-index-links=never T17171b.hs
T-signals-child:
-'$(RUNGHC)' T-signals-child.hs --runghc '$(RUNGHC)'
diff --git a/testsuite/tests/typecheck/should_fail/ErrorIndexLinks.hs b/testsuite/tests/typecheck/should_fail/ErrorIndexLinks.hs
new file mode 100644
index 000000000000..041c5b74a455
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/ErrorIndexLinks.hs
@@ -0,0 +1,7 @@
+-- | Test that GHC produces links to the Haskell Foundation Error Index Pretty
+-- straight forward, we just induce a type error and track the link as a golden
+-- test.
+
+module Main where
+
+main = 1 + "hello HF! from GHC"
diff --git a/testsuite/tests/typecheck/should_fail/ErrorIndexLinks.stderr b/testsuite/tests/typecheck/should_fail/ErrorIndexLinks.stderr
new file mode 100644
index 000000000000..69f6c322f582
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/ErrorIndexLinks.stderr
@@ -0,0 +1,7 @@
+
+ErrorIndexLinks.hs:7:1: error: []8;;https://errors.haskell.org/messages/GHC-83865\GHC-83865]8;;\]
+ • Couldn't match type: [Char]
+ with: IO t0
+ Expected: IO t0
+ Actual: String
+ • When checking the type of the IO action ‘main’
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index dffa11aad241..d5d40040db81 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -701,3 +701,4 @@ test('T23514a', normal, compile_fail, [''])
test('T22478c', normal, compile_fail, [''])
test('T23776', normal, compile, ['']) # to become an error in GHC 9.12
test('T17940', normal, compile_fail, [''])
+test('ErrorIndexLinks', normal, compile_fail, ['-fprint-error-index-links=always'])
--
GitLab