Add -fsuppress-error-contexts to disable printing error contexts in errorswip/suppress-err-context

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

11 files changed, 56 insertions, 16 deletions

diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 209e6d1776..b6d198789e 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -375,6 +375,9 @@ data GeneralFlag
    | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps
    | Opt_SuppressCoreSizes  -- ^ Suppress per binding Core size stats in dumps
 
+   -- Error message suppression
+   | Opt_SuppressErrorContext
+
    -- temporary flags
    | Opt_AutoLinkPackages
    | Opt_ImplicitImportQualified
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 627b2c69b3..9bfcd1a382 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3501,7 +3501,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 "suppress-error-contexts"          Opt_SuppressErrorContext
 
   ]
   ++ fHoleFlags
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 237c6fa4a3..8ca2d2c6da 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -1171,9 +1171,12 @@ mkErrorReport tcl_env msg mb_ctxt supplementary
              ErrInfo
                (fromMaybe empty mb_context)
                (vcat $ map (pprSolverReportSupplementary hfdc) supplementary)
+       ; detailed_msg <- mkDetailedMessage err_info msg
        ; mkTcRnMessage
            (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing)
-           (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) }
+           (TcRnMessageWithInfo unit_state $ detailed_msg) }
+
+
 
 -- | Pretty-print supplementary information, to add to an error report.
 pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 35bfea6ae1..87f482a290 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -97,8 +97,8 @@ instance Diagnostic TcRnMessage where
       -> diagnosticMessage m
     TcRnMessageWithInfo unit_state msg_with_info
       -> case msg_with_info of
-           TcRnMessageDetailed err_info msg
-             -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg)
+           TcRnMessageDetailed err_info suppress_ctx msg
+             -> messageWithInfoDiagnosticMessage unit_state err_info suppress_ctx (diagnosticMessage msg)
     TcRnSolverReport msgs _ _
       -> mkDecorated $
            map pprSolverReportWithCtxt msgs
@@ -962,7 +962,7 @@ instance Diagnostic TcRnMessage where
       -> diagnosticReason m
     TcRnMessageWithInfo _ msg_with_info
       -> case msg_with_info of
-           TcRnMessageDetailed _ m -> diagnosticReason m
+           TcRnMessageDetailed _ _ m -> diagnosticReason m
     TcRnSolverReport _ reason _
       -> reason -- Error, or a Warning if we are deferring type errors
     TcRnRedundantConstraints {}
@@ -1276,7 +1276,7 @@ instance Diagnostic TcRnMessage where
       -> diagnosticHints m
     TcRnMessageWithInfo _ msg_with_info
       -> case msg_with_info of
-           TcRnMessageDetailed _ m -> diagnosticHints m
+           TcRnMessageDetailed _ _ m -> diagnosticHints m
     TcRnSolverReport _ _ hints
       -> hints
     TcRnRedundantConstraints{}
@@ -1679,10 +1679,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{..} suppress_ctxt important =
+  let err_info' = map (pprWithUnitState unit_state) ([errInfoContext | not suppress_ctxt] ++ [errInfoSupplementary])
       in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc`
          mkDecorated err_info'
 
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 62732ed8dd..b257c97fc0 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -166,6 +166,8 @@ data ErrInfo = ErrInfo {
 data TcRnMessageDetailed
   = TcRnMessageDetailed !ErrInfo
                         -- ^ Extra info associated with the message
+                        !Bool
+                        -- ^ Suppress extra context information
                         !TcRnMessage
 
 -- | An error which might arise during typechecking/renaming.
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index af4575c490..b8309cfa5b 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -1096,8 +1096,8 @@ tc_infer_id id_name
         hint_msg = vcat $ map ppr hints
         import_err_msg = vcat $ map ppr import_errs
         info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }
-        msg = TcRnMessageWithInfo unit_state
-            $ TcRnMessageDetailed info (TcRnIncorrectNameSpace nm False)
+      msg <- TcRnMessageWithInfo unit_state <$>
+              mkDetailedMessage info (TcRnIncorrectNameSpace nm False)
       failWithTc msg
 
     get_suggestions ns = do
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 571e02c7cf..efe30fca02 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -70,7 +70,7 @@ module GHC.Tc.Utils.Monad(
   addErrAt, addErrs,
   checkErr,
   addMessages,
-  discardWarnings,
+  discardWarnings, mkDetailedMessage,
 
   -- * Usage environment
   tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,
@@ -1068,7 +1068,12 @@ addErrAt :: SrcSpan -> TcRnMessage -> TcRn ()
 addErrAt loc msg = do { ctxt <- getErrCtxt
                       ; tidy_env <- tcInitTidyEnv
                       ; err_info <- mkErrInfo tidy_env ctxt
-                      ; add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) }
+                      ; detailed_msg <- mkDetailedMessage (ErrInfo err_info Outputable.empty) msg
+                      ; add_long_err_at loc detailed_msg }
+
+mkDetailedMessage :: ErrInfo -> TcRnMessage -> TcM TcRnMessageDetailed
+mkDetailedMessage err_info msg =
+  TcRnMessageDetailed err_info <$> goptM Opt_SuppressErrorContext <*> pure msg
 
 addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn ()
 addErrs msgs = mapM_ add msgs
@@ -1601,7 +1606,8 @@ addDiagnosticTcM (env0, msg)
  = do { ctxt <- getErrCtxt
       ; extra <- mkErrInfo env0 ctxt
       ; let err_info = ErrInfo extra Outputable.empty
-      ; add_diagnostic (TcRnMessageDetailed err_info msg) }
+      ; detailed_msg <- mkDetailedMessage err_info msg
+      ; add_diagnostic detailed_msg }
 
 -- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage'
 -- given some additional context about the diagnostic.
@@ -1623,13 +1629,13 @@ addTcRnDiagnostic msg = do
 -- | Display a diagnostic for the current source location, taken from
 -- the 'TcRn' monad.
 addDiagnostic :: TcRnMessage -> TcRn ()
-addDiagnostic msg = add_diagnostic (TcRnMessageDetailed no_err_info msg)
+addDiagnostic msg = add_diagnostic =<< mkDetailedMessage no_err_info msg
 
 -- | Display a diagnostic for a given source location.
 addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn ()
 addDiagnosticAt loc msg = do
   unit_state <- hsc_units <$> getTopEnv
-  let dia = TcRnMessageDetailed no_err_info msg
+  dia <-  mkDetailedMessage no_err_info msg
   mkTcRnMessage loc (TcRnMessageWithInfo unit_state dia) >>= reportDiagnostic
 
 -- | Display a diagnostic, with an optional flag, for the current source
@@ -1652,7 +1658,7 @@ add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan
             -> TcM ()
 add_err_tcm tidy_env msg loc ctxt
  = do { err_info <- mkErrInfo tidy_env ctxt ;
-        add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) }
+        add_long_err_at loc =<< (mkDetailedMessage (ErrInfo err_info Outputable.empty) msg) }
 
 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
 -- Tidy the error info, trimming excessive contexts
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index ee61a89ce1..a3ccd2c168 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:: -fsuppress-error-contexts
+    :shortdesc: Whether to show textual information about error context
+    :type: dynamic
+    :reverse: -fno-suppress-error-contexts
+    :category: verbosity
+
+    :default: off
+
+    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..7fa43973dd
--- /dev/null
+++ b/testsuite/tests/driver/T21722.stderr
@@ -0,0 +1,5 @@
+
+T21722.hs:6:11: error:
+    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 624c8305dc..58bbdda1a6 100644
--- a/testsuite/tests/driver/all.T
+++ b/testsuite/tests/driver/all.T
@@ -309,3 +309,4 @@ test('T16476a', normal, makefile_test, [])
 test('T16476b', normal, makefile_test, [])
 test('T20569', extra_files(["T20569/"]), makefile_test, [])
 test('T21349', extra_files(['T21349']), makefile_test, [])
+test('T21722', normal, compile_fail, ['-fsuppress-error-contexts'])