Display results of GHC.Core.Lint.lint* functions consistentlywip/T18770

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.

1 files changed, 36 insertions, 40 deletions

diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 6fdcb02c8c..1988322dd4 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"
@@ -51,7 +51,6 @@ import GHC.Types.Name.Env
 import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Core.Ppr
-import GHC.Utils.Error
 import GHC.Core.Coercion
 import GHC.Types.SrcLoc
 import GHC.Core.Type as Type
@@ -66,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
@@ -373,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 ()
   where
@@ -415,29 +420,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.
@@ -466,7 +460,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]
@@ -542,16 +536,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 $
@@ -565,11 +559,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 $
@@ -2328,13 +2322,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