Display results of GHC.Core.Lint.lint* functions consistently

Previously, the functions in `GHC.Core.Lint` used a patchwork of
different ways to display Core Lint errors:

* `lintPassResult` (which is the source of most Core Lint errors) renders
  Core Lint errors with a distinctive banner (e.g.,
  `*** Core Lint errors : in result of ... ***`) that sets them apart
  from ordinary GHC error messages.
* `lintAxioms`, in contrast, uses a completely different code path that
  displays Core Lint errors in a rather confusing manner. For example,
  the program in #18770 would give these results:

  ```
  Bug.hs:1:1: error:
      Bug.hs:12:1: warning:
          Non-*-like kind when *-like expected: RuntimeRep
          when checking the body of forall: 'TupleRep '[r]
          In the coercion axiom Bug.N:T :: []. Bug.T ~_R Any
          Substitution: [TCvSubst
                           In scope: InScope {r}
                           Type env: [axl :-> r]
                           Co env: []]
    |
  1 | {-# LANGUAGE DataKinds #-}
    | ^
  ```
* Further digging reveals that `GHC.IfaceToCore` displays Core Lint
  errors for iface unfoldings as though they were a GHC panic. See, for
  example, this excerpt from #17723:

  ```
  ghc: panic! (the 'impossible' happened)
    (GHC version 8.8.2 for x86_64-unknown-linux):
          Iface Lint failure
    In interface for Lib
    ...
  ```

This patch makes all of these code paths display Core Lint errors and
warnings consistently. I decided to adopt the conventions that
`lintPassResult` currently uses, as they appear to have been around the
longest (and look the best, in my subjective opinion). We now use the
`displayLintResult` function for all three scenarios mentioned above.
For example, here is what the Core Lint error for the program in #18770 looks
like after this patch:

```
[1 of 1] Compiling Bug              ( Bug.hs, Bug.o )
*** Core Lint errors : in result of TcGblEnv axioms ***
Bug.hs:12:1: warning:
    Non-*-like kind when *-like expected: RuntimeRep
    when checking the body of forall: 'TupleRep '[r_axn]
    In the coercion axiom N:T :: []. T ~_R Any
    Substitution: [TCvSubst
                     In scope: InScope {r_axn}
                     Type env: [axn :-> r_axn]
                     Co env: []]
*** Offending Program ***
axiom N:T :: T = Any -- Defined at Bug.hs:12:1
*** End of Offense ***

<no location info>: error:
Compilation had errors
```

Fixes #18770.

6 files changed, 54 insertions, 63 deletions

diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 5104b00c61..a61b788dc9 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -19,8 +19,8 @@ module GHC.Core.Lint (
 
     -- ** Debug output
     endPass, endPassIO,
-    dumpPassResult,
-    GHC.Core.Lint.dumpIfSet,
+    displayLintResults, dumpPassResult,
+    dumpIfSet,
  ) where
 
 #include "HsVersions.h"
@@ -65,7 +65,8 @@ import GHC.Core.TyCon as TyCon
 import GHC.Core.Coercion.Axiom
 import GHC.Core.Unify
 import GHC.Types.Basic
-import GHC.Utils.Error as Err
+import GHC.Utils.Error hiding ( dumpIfSet )
+import qualified GHC.Utils.Error as Err
 import GHC.Data.List.SetOps
 import GHC.Builtin.Names
 import GHC.Utils.Outputable as Outputable
@@ -372,33 +373,38 @@ lintPassResult hsc_env pass binds
   | not (gopt Opt_DoCoreLinting dflags)
   = return ()
   | otherwise
-  = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
+  = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
        ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
-       ; displayLintResults dflags pass warns errs binds  }
+       ; displayLintResults dflags (showLintWarnings pass) (ppr pass)
+                            (pprCoreBindings binds) warns_and_errs }
   where
     dflags = hsc_dflags hsc_env
 
-displayLintResults :: DynFlags -> CoreToDo
-                   -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
+displayLintResults :: DynFlags
+                   -> Bool -- ^ If 'True', display linter warnings.
+                           --   If 'False', ignore linter warnings.
+                   -> SDoc -- ^ The source of the linted program
+                   -> SDoc -- ^ The linted program, pretty-printed
+                   -> WarnsAndErrs
                    -> IO ()
-displayLintResults dflags pass warns errs binds
+displayLintResults dflags display_warnings pp_what pp_pgm (warns, errs)
   | not (isEmptyBag errs)
   = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan
            $ withPprStyle defaultDumpStyle
-           (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
+           (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs
                  , text "*** Offending Program ***"
-                 , pprCoreBindings binds
+                 , pp_pgm
                  , text "*** End of Offense ***" ])
        ; Err.ghcExit dflags 1 }
 
   | not (isEmptyBag warns)
   , not (hasNoDebugOutput dflags)
-  , showLintWarnings pass
+  , display_warnings
   -- If the Core linter encounters an error, output to stderr instead of
   -- stdout (#13342)
   = putLogMsg dflags NoReason Err.SevInfo noSrcSpan
       $ withPprStyle defaultDumpStyle
-        (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
+        (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
 
   | otherwise = return ()
 
@@ -413,29 +419,18 @@ showLintWarnings :: CoreToDo -> Bool
 showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
 showLintWarnings _ = True
 
-lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
+lintInteractiveExpr :: SDoc -- ^ The source of the linted expression
+                    -> HscEnv -> CoreExpr -> IO ()
 lintInteractiveExpr what hsc_env expr
   | not (gopt Opt_DoCoreLinting dflags)
   = return ()
   | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr
-  = do { display_lint_err err
-       ; Err.ghcExit dflags 1 }
+  = displayLintResults dflags False what (pprCoreExpr expr) (emptyBag, err)
   | otherwise
   = return ()
   where
     dflags = hsc_dflags hsc_env
 
-    display_lint_err err
-      = do { putLogMsg dflags NoReason Err.SevDump
-               noSrcSpan
-               $ withPprStyle defaultDumpStyle
-               (vcat [ lint_banner "errors" (text what)
-                     , err
-                     , text "*** Offending Program ***"
-                     , pprCoreExpr expr
-                     , text "*** End of Offense ***" ])
-           ; Err.ghcExit dflags 1 }
-
 interactiveInScope :: HscEnv -> [Var]
 -- In GHCi we may lint expressions, or bindings arising from 'deriving'
 -- clauses, that mention variables bound in the interactive context.
@@ -464,7 +459,7 @@ interactiveInScope hsc_env
               -- where t is a RuntimeUnk (see TcType)
 
 -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
-lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
+lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
 --   Returns (warnings, errors)
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
@@ -540,16 +535,16 @@ hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore.
 
 -}
 
-lintUnfolding :: Bool           -- True <=> is a compulsory unfolding
+lintUnfolding :: Bool               -- True <=> is a compulsory unfolding
               -> DynFlags
               -> SrcLoc
-              -> VarSet         -- Treat these as in scope
+              -> VarSet             -- Treat these as in scope
               -> CoreExpr
-              -> Maybe MsgDoc   -- Nothing => OK
+              -> Maybe (Bag MsgDoc) -- Nothing => OK
 
 lintUnfolding is_compulsory dflags locn var_set expr
   | isEmptyBag errs = Nothing
-  | otherwise       = Just (pprMessageBag errs)
+  | otherwise       = Just errs
   where
     vars = nonDetEltsUniqSet var_set
     (_warns, errs) = initL dflags (defaultLintFlags dflags) vars $
@@ -563,11 +558,11 @@ lintUnfolding is_compulsory dflags locn var_set expr
 lintExpr :: DynFlags
          -> [Var]               -- Treat these as in scope
          -> CoreExpr
-         -> Maybe MsgDoc        -- Nothing => OK
+         -> Maybe (Bag MsgDoc)  -- Nothing => OK
 
 lintExpr dflags vars expr
   | isEmptyBag errs = Nothing
-  | otherwise       = Just (pprMessageBag errs)
+  | otherwise       = Just errs
   where
     (_warns, errs) = initL dflags (defaultLintFlags dflags) vars linter
     linter = addLoc TopLevelBindings $
@@ -2326,13 +2321,15 @@ lintCoercion (HoleCo h)
 -}
 
 lintAxioms :: DynFlags
+           -> SDoc -- ^ The source of the linted axioms
            -> [CoAxiom Branched]
-           -> WarnsAndErrs
-lintAxioms dflags axioms
-  = initL dflags (defaultLintFlags dflags) [] $
-    do { mapM_ lint_axiom axioms
-       ; let axiom_groups = groupWith coAxiomTyCon axioms
-       ; mapM_ lint_axiom_group axiom_groups }
+           -> IO ()
+lintAxioms dflags what axioms =
+  displayLintResults dflags True what (vcat $ map pprCoAxiom axioms) $
+  initL dflags (defaultLintFlags dflags) [] $
+  do { mapM_ lint_axiom axioms
+     ; let axiom_groups = groupWith coAxiomTyCon axioms
+     ; mapM_ lint_axiom_group axiom_groups }
 
 lint_axiom :: CoAxiom Branched -> LintM ()
 lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index d12099f21b..0f5476634e 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1713,7 +1713,7 @@ hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
 
   -- Desugar it
   ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
-  liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
+  liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)
   handleWarnings
 
   -- Then code-gen, and link it
@@ -1955,7 +1955,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
          ; prepd_expr <- corePrepExpr hsc_env tidy_expr
 
            {- Lint if necessary -}
-         ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
+         ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr
 
            {- Convert to BCOs -}
          ; bcos <- coreExprToBCOs hsc_env
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 6a4861c727..de0fa6f023 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -62,6 +62,7 @@ import GHC.Core.TyCon
 import GHC.Core.ConLike
 import GHC.Core.DataCon
 import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
+import GHC.Core.Ppr
 
 import GHC.Unit.External
 import GHC.Unit.Module
@@ -73,6 +74,7 @@ import GHC.Utils.Outputable
 import GHC.Utils.Misc
 import GHC.Utils.Panic
 
+import GHC.Data.Bag
 import GHC.Data.Maybe
 import GHC.Data.FastString
 import GHC.Data.List.SetOps
@@ -1199,13 +1201,11 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
                                         bndrs' ++
                                         exprsFreeIdsList args')
                       ; case lintExpr dflags in_scope rhs' of
-                          Nothing       -> return ()
-                          Just fail_msg -> do { mod <- getIfModule
-                                              ; pprPanic "Iface Lint failure"
-                                                  (vcat [ text "In interface for" <+> ppr mod
-                                                        , hang doc 2 fail_msg
-                                                        , ppr name <+> equals <+> ppr rhs'
-                                                        , text "Iface expr =" <+> ppr rhs ]) } }
+                          Nothing   -> return ()
+                          Just errs -> liftIO $
+                            displayLintResults dflags False doc
+                                               (pprCoreExpr rhs')
+                                               (emptyBag, errs) }
                    ; return (bndrs', args', rhs') }
         ; let mb_tcs = map ifTopFreeName args
         ; this_mod <- getIfModule
@@ -1724,13 +1724,10 @@ tcPragExpr is_compulsory toplvl name expr
         in_scope <- get_in_scope
         dflags   <- getDynFlags
         case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of
-          Nothing       -> return ()
-          Just fail_msg -> do { mod <- getIfModule
-                              ; pprPanic "Iface Lint failure"
-                                  (vcat [ text "In interface for" <+> ppr mod
-                                        , hang doc 2 fail_msg
-                                        , ppr name <+> equals <+> ppr core_expr'
-                                        , text "Iface expr =" <+> ppr expr ]) }
+          Nothing   -> return ()
+          Just errs -> liftIO $
+            displayLintResults dflags False doc
+                               (pprCoreExpr core_expr') (emptyBag, errs)
     return core_expr'
   where
     doc = ppWhen is_compulsory (text "Compulsory") <+>
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 40a59f965d..10461ad5fe 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -296,11 +296,7 @@ tcRnModuleTcRnM hsc_env mod_sum
                                  tcRnSrcDecls explicit_mod_hdr local_decls export_ies
 
                ; whenM (goptM Opt_DoCoreLinting) $
-                 do { let (warns, errs) = lintGblEnv (hsc_dflags hsc_env) tcg_env
-                    ; mapBagM_ (addWarn NoReason) warns
-                    ; mapBagM_ addErr errs
-                    ; failIfErrsM }  -- if we have a lint error, we're only
-                                     -- going to get in deeper trouble by proceeding
+                 lintGblEnv (hsc_dflags hsc_env) tcg_env
 
                ; setGblEnv tcg_env
                  $ do { -- Process the export list
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 3cda5de56f..2f41bb4b14 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -1712,7 +1712,8 @@ getRoleAnnots bndrs role_env
 
 -- | Check the 'TcGblEnv' for consistency. Currently, only checks
 -- axioms, but should check other aspects, too.
-lintGblEnv :: DynFlags -> TcGblEnv -> (Bag SDoc, Bag SDoc)
-lintGblEnv dflags tcg_env = lintAxioms dflags axioms
+lintGblEnv :: DynFlags -> TcGblEnv -> TcM ()
+lintGblEnv dflags tcg_env =
+  liftIO $ lintAxioms dflags (text "TcGblEnv axioms") axioms
   where
     axioms = typeEnvCoAxioms (tcg_type_env tcg_env)
diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs
index 0ec56b8894..7ac0303820 100644
--- a/testsuite/tests/callarity/unittest/CallArity1.hs
+++ b/testsuite/tests/callarity/unittest/CallArity1.hs
@@ -172,7 +172,7 @@ main = do
         dflags <- getSessionDynFlags
         liftIO $ forM_ exprs $ \(n,e) -> do
             case lintExpr dflags [f,scrutf,scruta] e of
-                Just msg -> putMsg dflags (msg $$ text "in" <+> text n)
+                Just errs -> putMsg dflags (pprMessageBag errs $$ text "in" <+> text n)
                 Nothing -> return ()
             putMsg dflags (text n Outputable.<> char ':')
             -- liftIO $ putMsg dflags (ppr e)