Add -fsuppress-error-contexts to disable printing error contexts in errorswip/diagnostics-config

In many development environments, the source span is the primary means
of seeing what an error message relates to, and the In the expression:
and In an equation for: clauses are not particularly relevant. However,
they can grow to be quite long, which can make the message itself both
feel overwhelming and interact badly with limited-space areas.

It's simple to implement this flag so we might as well do it and give
the user control about how they see their messages.

Fixes #21722

9 files changed, 51 insertions, 10 deletions

diff --git a/compiler/GHC/Driver/Config/Diagnostic.hs b/compiler/GHC/Driver/Config/Diagnostic.hs
index e8bf0f5926..3a590abc9f 100644
--- a/compiler/GHC/Driver/Config/Diagnostic.hs
+++ b/compiler/GHC/Driver/Config/Diagnostic.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeApplications #-}
+
 -- | Functions for initialising error message printing configuration from the
 -- GHC session flags.
 module GHC.Driver.Config.Diagnostic
@@ -21,6 +21,7 @@ import GHC.Driver.Errors.Ppr ()
 import GHC.Tc.Errors.Types
 import GHC.HsToCore.Errors.Types
 import GHC.Types.Error
+import GHC.Tc.Errors.Ppr
 
 -- | Initialise the general configuration for printing diagnostic messages
 -- For example, this configuration controls things like whether warnings are
@@ -47,7 +48,7 @@ initPsMessageOpts :: DynFlags -> DiagnosticOpts PsMessage
 initPsMessageOpts _ = NoDiagnosticOpts
 
 initTcMessageOpts :: DynFlags -> DiagnosticOpts TcRnMessage
-initTcMessageOpts _ = NoDiagnosticOpts
+initTcMessageOpts dflags = TcRnMessageOpts { tcOptsShowContext = gopt Opt_ShowErrorContext dflags }
 
 initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage
 initDsMessageOpts _ = NoDiagnosticOpts
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 83d87b6898..0651e1c475 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -427,6 +427,9 @@ data GeneralFlag
    | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps
    | Opt_SuppressCoreSizes  -- ^ Suppress per binding Core size stats in dumps
 
+   -- Error message suppression
+   | Opt_ShowErrorContext
+
    -- temporary flags
    | Opt_AutoLinkPackages
    | Opt_ImplicitImportQualified
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 68a925f901..ff2b73eea3 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -4,7 +4,6 @@
 {-# LANGUAGE NondecreasingIndentation #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 {-# LANGUAGE FlexibleContexts #-}
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index cf6a5da5e3..836ad88005 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3508,7 +3508,8 @@ fFlagsDeps = [
       (\turn_on -> updM (\dflags -> do
         unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on)
                (addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.")
-        return dflags))
+        return dflags)),
+  flagSpec "show-error-context"               Opt_ShowErrorContext
 
   ]
   ++ fHoleFlags
@@ -3802,7 +3803,9 @@ defaultFlags settings
       Opt_VersionMacros,
       Opt_RPath,
       Opt_DumpWithWays,
-      Opt_CompactUnwind
+      Opt_CompactUnwind,
+      Opt_ShowErrorContext
+
     ]
 
     ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 993b62a7ea..2842362a8f 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -18,6 +18,7 @@ module GHC.Tc.Errors.Ppr
   , withHsDocContext
   , pprHsDocContext
   , inHsDocContext
+  , TcRnMessageOpts(..)
   )
   where
 
@@ -96,16 +97,25 @@ import Data.Ord ( comparing )
 import Data.Bifunctor
 import GHC.Types.Name.Env
 
+data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not
+                                       }
+
+defaultTcRnMessageOpts :: TcRnMessageOpts
+defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True }
+
+
 instance Diagnostic TcRnMessage where
-  type DiagnosticOpts TcRnMessage = NoDiagnosticOpts
-  defaultDiagnosticOpts = NoDiagnosticOpts
+  type DiagnosticOpts TcRnMessage = TcRnMessageOpts
+  defaultDiagnosticOpts = defaultTcRnMessageOpts
   diagnosticMessage opts = \case
     TcRnUnknownMessage (UnknownDiagnostic @e m)
       -> diagnosticMessage (defaultDiagnosticOpts @e) m
     TcRnMessageWithInfo unit_state msg_with_info
       -> case msg_with_info of
            TcRnMessageDetailed err_info msg
-             -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage opts msg)
+             -> messageWithInfoDiagnosticMessage unit_state err_info
+                  (tcOptsShowContext opts)
+                  (diagnosticMessage opts msg)
     TcRnSolverReport msg _ _
       -> mkSimpleDecorated $ pprSolverReportWithCtxt msg
     TcRnRedundantConstraints redundants (info, show_info)
@@ -1807,10 +1817,11 @@ deriveInstanceErrReasonHints cls newtype_deriving = \case
 
 messageWithInfoDiagnosticMessage :: UnitState
                                  -> ErrInfo
+                                 -> Bool
                                  -> DecoratedSDoc
                                  -> DecoratedSDoc
-messageWithInfoDiagnosticMessage unit_state ErrInfo{..} important =
-  let err_info' = map (pprWithUnitState unit_state) [errInfoContext, errInfoSupplementary]
+messageWithInfoDiagnosticMessage unit_state ErrInfo{..} show_ctxt important =
+  let err_info' = map (pprWithUnitState unit_state) ([errInfoContext | show_ctxt] ++ [errInfoSupplementary])
       in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc`
          mkDecorated err_info'
 
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index ca8d75860f..ecb64bbdb2 100644
--- a/docs/users_guide/using.rst
+++ b/docs/users_guide/using.rst
@@ -1360,6 +1360,18 @@ messages and in GHCi:
     error was detected.  This also affects the associated caret symbol that
     points at the region of code at fault.
 
+.. ghc-flag:: -fshow-error-context
+    :shortdesc: Whether to show textual information about error context
+    :type: dynamic
+    :reverse: -fno-show-error-context
+    :category: verbosity
+
+    :default: on
+
+    Controls whether GHC displays information about the context in which an
+    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:: -ferror-spans
     :shortdesc: Output full span in error messages
     :type: dynamic
diff --git a/testsuite/tests/driver/T21722.hs b/testsuite/tests/driver/T21722.hs
new file mode 100644
index 0000000000..fe40aadc61
--- /dev/null
+++ b/testsuite/tests/driver/T21722.hs
@@ -0,0 +1,6 @@
+module T21722 where
+
+main = print ()
+  where
+    foo :: Int
+    foo = "abc"
diff --git a/testsuite/tests/driver/T21722.stderr b/testsuite/tests/driver/T21722.stderr
new file mode 100644
index 0000000000..e66bbb3bea
--- /dev/null
+++ b/testsuite/tests/driver/T21722.stderr
@@ -0,0 +1,5 @@
+
+T21722.hs:6:11: error: [GHC-83865]
+    Couldn't match type ‘[Char]’ with ‘Int’
+    Expected: Int
+      Actual: String
diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T
index 6a0932e9b0..3d1b417c91 100644
--- a/testsuite/tests/driver/all.T
+++ b/testsuite/tests/driver/all.T
@@ -313,3 +313,4 @@ test('T21349', extra_files(['T21349']), makefile_test, [])
 test('T21869', [normal, when(unregisterised(), skip)], makefile_test, [])
 test('T22044', normal, makefile_test, [])
 test('T22048', [only_ways(['normal']), grep_errmsg("_rule")], compile, ["-O -fomit-interface-pragmas -ddump-simpl"])
+test('T21722', normal, compile_fail, ['-fno-show-error-context'])