Improve error reporting in generated code

Our error reporting in generated code (via desugaring before
typechecking) only worked when the generated code was just a simple
call. This commit makes it work in nested cases.

16 files changed, 126 insertions, 86 deletions

diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 597af3d778..be0b12a278 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -20,7 +20,7 @@ module GHC.Rename.Utils (
         mkFieldEnv,
         badQualBndrErr, typeAppErr, badFieldConErr,
         wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,
-        genHsIntegralLit, genHsTyLit,
+        genHsIntegralLit, genHsTyLit, genSimpleConPat,
 
         newLocalBndrRn, newLocalBndrsRn,
 
@@ -676,3 +676,13 @@ genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)
 
 genHsTyLit :: FastString -> HsType GhcRn
 genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText
+
+genSimpleConPat :: Name -> [Name] -> LPat GhcRn
+-- The pattern (C x1 .. xn)
+genSimpleConPat con args
+  = wrapGenSpan $ ConPat { pat_con_ext = noExtField
+                         , pat_con     = wrapGenSpan con
+                         , pat_args    = PrefixCon [] (map genVarPat args) }
+
+genVarPat :: Name -> LPat GhcRn
+genVarPat n = wrapGenSpan $ VarPat noExtField (wrapGenSpan n)
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 86aac8d99d..e8cf8ce097 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -46,7 +46,7 @@ import GHC.Hs
 
 import GHC.Tc.Errors.Types
 import GHC.Tc.Types.Constraint
-import {-# SOURCE #-} GHC.Tc.Types (getLclEnvLoc)
+import {-# SOURCE #-} GHC.Tc.Types( getLclEnvLoc, lclEnvInGeneratedCode )
 import GHC.Tc.Types.Origin
 import GHC.Tc.Types.Rank (Rank(..))
 import GHC.Tc.Utils.TcType
@@ -1913,7 +1913,7 @@ pprTcSolverReportMsg _
             , mismatch_item = item
             , mismatch_ty1  = ty1
             , mismatch_ty2  = ty2 })
-  = addArising (errorItemOrigin item) msg
+  = addArising (errorItemCtLoc item) msg
   where
     msg
       | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) ||
@@ -1979,7 +1979,7 @@ pprTcSolverReportMsg ctxt
                   , teq_mismatch_expected = exp
                   , teq_mismatch_actual   = act
                   , teq_mismatch_what     = mb_thing })
-  = addArising orig $ pprWithExplicitKindsWhen ppr_explicit_kinds msg
+  = addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg
   where
     msg
       | isUnliftedTypeKind act, isLiftedTypeKind exp
@@ -2155,7 +2155,7 @@ pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) =
 pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) =
   let givens = getUserGivens ctxt
   in if null givens
-     then addArising (errorItemOrigin item) $
+     then addArising (errorItemCtLoc item) $
             sep [ text "Unbound implicit parameter" <> plural preds
                 , nest 2 (pprParendTheta preds) ]
      else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (item :| items) Nothing)
@@ -2171,9 +2171,9 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extr
   where
     main_msg
       | null useful_givens
-      = addArising orig (no_instance_msg <+> missing)
+      = addArising ct_loc (no_instance_msg <+> missing)
       | otherwise
-      = vcat (addArising orig (no_deduce_msg <+> missing)
+      = vcat (addArising ct_loc (no_deduce_msg <+> missing)
               : pp_givens useful_givens)
 
     supplementary = case mb_extra of
@@ -2181,7 +2181,8 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extr
         -> Left []
       Just (CND_Extra level ty1 ty2)
         -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig
-    orig = errorItemOrigin item
+    ct_loc = errorItemCtLoc item
+    orig   = ctLocOrigin ct_loc
     wanteds = map errorItemPred (item:others)
 
     no_instance_msg =
@@ -2203,7 +2204,7 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extr
 
 pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt item ambigs) =
   pprTcSolverReportInfo ctxt (Ambiguity True ambigs) <+>
-  pprArising (errorItemOrigin item) $$
+  pprArising (errorItemCtLoc item) $$
   text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item)
   <+> text "from being solved."
 pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})
@@ -2304,7 +2305,7 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})
 
 pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) =
   vcat
-    [ addArising orig $
+    [ addArising ct_loc $
         (text "Overlapping instances for"
         <+> pprType (mkClassPred clas tys))
     , ppUnless (null matching_givens) $
@@ -2339,7 +2340,8 @@ pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item match
                            , text "when compiling the other instance declarations"]
                ])]
   where
-    orig            = errorItemOrigin item
+    ct_loc          = errorItemCtLoc item
+    orig            = ctLocOrigin ct_loc
     pred            = errorItemPred item
     (clas, tys)     = getClassPredTys pred
     tyCoVars        = tyCoVarsOfTypesList tys
@@ -2363,7 +2365,7 @@ pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item match
                                           && isJust (tcMatchTys tys tys')
                      Nothing -> False
 pprTcSolverReportMsg _ (UnsafeOverlap item matches unsafe_overlapped) =
-  vcat [ addArising orig (text "Unsafe overlapping instances for"
+  vcat [ addArising ct_loc (text "Unsafe overlapping instances for"
                   <+> pprType (mkClassPred clas tys))
        , sep [text "The matching instance is:",
               nest 2 (pprInstance $ head matches)]
@@ -2375,7 +2377,7 @@ pprTcSolverReportMsg _ (UnsafeOverlap item matches unsafe_overlapped) =
               ]
        ]
   where
-    orig        = errorItemOrigin item
+    ct_loc      = errorItemCtLoc item
     pred        = errorItemPred item
     (clas, tys) = getClassPredTys pred
 
@@ -2906,20 +2908,28 @@ levelString :: TypeOrKind -> String
 levelString TypeLevel = "type"
 levelString KindLevel = "kind"
 
-pprArising :: CtOrigin -> SDoc
+pprArising :: CtLoc -> SDoc
 -- Used for the main, top-level error message
 -- We've done special processing for TypeEq, KindEq, givens
-pprArising (TypeEqOrigin {})         = empty
-pprArising (KindEqOrigin {})         = empty
-pprArising (AmbiguityCheckOrigin {}) = empty  -- the "In the ambiguity check" context
-                                              -- is sufficient; this would just be
-                                              -- repetitive
-pprArising orig | isGivenOrigin orig = empty
-                | otherwise          = pprCtOrigin orig
+pprArising ct_loc
+  | in_generated_code = empty  -- See Note ["Arising from" messages in generated code]
+  | suppress_origin   = empty
+  | otherwise         = pprCtOrigin orig
+  where
+    orig = ctLocOrigin ct_loc
+    in_generated_code = lclEnvInGeneratedCode (ctLocEnv ct_loc)
+    suppress_origin
+      | isGivenOrigin orig = True
+      | otherwise          = case orig of
+          TypeEqOrigin {}         -> True -- We've done special processing
+          KindEqOrigin {}         -> True -- for TypeEq, KindEq, givens
+          AmbiguityCheckOrigin {} -> True -- The "In the ambiguity check" context
+                                          -- is sufficient; more would be repetitive
+          _ -> False
 
 -- Add the "arising from..." part to a message
-addArising :: CtOrigin -> SDoc -> SDoc
-addArising orig msg = hang msg 2 (pprArising orig)
+addArising :: CtLoc -> SDoc -> SDoc
+addArising ct_loc msg = hang msg 2 (pprArising ct_loc)
 
 pprWithArising :: [Ct] -> SDoc
 -- Print something like
@@ -2931,7 +2941,7 @@ pprWithArising []
   = panic "pprWithArising"
 pprWithArising (ct:cts)
   | null cts
-  = addArising (ctLocOrigin loc) (pprTheta [ctPred ct])
+  = addArising loc (pprTheta [ctPred ct])
   | otherwise
   = vcat (map ppr_one (ct:cts))
   where
@@ -2939,6 +2949,19 @@ pprWithArising (ct:cts)
     ppr_one ct' = hang (parens (pprType (ctPred ct')))
                      2 (pprCtLoc (ctLoc ct'))
 
+{- Note ["Arising from" messages in generated code]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider code generated when we desugar code before typechecking;
+see Note [Rebindable syntax and HsExpansion].
+
+In this code, constraints may be generated, but we don't want to
+say "arising from a call of foo" if 'foo' doesn't appear in the
+users code.  We leave the actual CtOrigin untouched (partly because
+it is generated in many, many places), but suppress the "Arising from"
+message for constraints that originate in generated code.
+-}
+
+
 {- *********************************************************************
 *                                                                      *
                            SkolemInfo
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index e72e3ed194..8f59daf24a 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -733,18 +733,9 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
                                    , text "do_ql" <+> ppr do_ql ])
        ; go emptyVarSet [] [] fun_sigma rn_args }
   where
-    fun_loc  = appCtxtLoc fun_ctxt
     fun_orig = exprCtOrigin (case fun_ctxt of
                                VAExpansion e _ -> e
                                VACall e _ _    -> e)
-    set_fun_ctxt thing_inside
-      | not (isGoodSrcSpan fun_loc)   -- noSrcSpan => no arguments
-      = thing_inside                  -- => context is already set
-      | otherwise
-      = setSrcSpan fun_loc $
-        case fun_ctxt of
-          VAExpansion orig _ -> addExprCtxt orig thing_inside
-          VACall {}          -> thing_inside
 
     -- Count value args only when complaining about a function
     -- applied to too many value args
@@ -803,9 +794,9 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
       | (tvs,   body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty
       , (theta, body2) <- tcSplitPhiTy body1
       , not (null tvs && null theta)
-      = do { (inst_tvs, wrap, fun_rho) <- set_fun_ctxt $
+      = do { (inst_tvs, wrap, fun_rho) <- addHeadCtxt fun_ctxt $
                                           instantiateSigma fun_orig tvs theta body2
-                 -- set_fun_ctxt: important for the class constraints
+                 -- addHeadCtxt: important for the class constraints
                  -- that may be emitted from instantiating fun_sigma
            ; go (delta `extendVarSetList` inst_tvs)
                 (addArgWrap wrap acc) so_far fun_rho args }
@@ -894,19 +885,26 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
 
 addArgCtxt :: AppCtxt -> LHsExpr GhcRn
            -> TcM a -> TcM a
--- Adds a "In the third argument of f, namely blah"
--- context, unless we are in generated code, in which case
--- use "In the expression: arg"
+-- There are two cases:
+-- * In the normal case, we add an informative context
+--      "In the third argument of f, namely blah"
+-- * If we are deep inside generated code (isGeneratedCode)
+--   or if all or part of this particular application is an expansion
+--   (VAExpansion), just use the less-informative context
+--       "In the expression: arg"
+--   Unless the arg is also a generated thing, in which case do nothing.
 ---See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
-addArgCtxt (VACall fun arg_no _) (L arg_loc arg) thing_inside
-  = setSrcSpanA arg_loc $
-    addErrCtxt (funAppCtxt fun arg arg_no) $
-    thing_inside
-
-addArgCtxt (VAExpansion {}) (L arg_loc arg) thing_inside
-  = setSrcSpanA arg_loc $
-    addExprCtxt arg    $  -- Auto-suppressed if arg_loc is generated
-    thing_inside
+addArgCtxt ctxt (L arg_loc arg) thing_inside
+  = do { in_generated_code <- inGeneratedCode
+       ; case ctxt of
+           VACall fun arg_no _ | not in_generated_code
+             -> setSrcSpanA arg_loc                    $
+                addErrCtxt (funAppCtxt fun arg arg_no) $
+                thing_inside
+
+           _ -> setSrcSpanA arg_loc $
+                addExprCtxt arg     $  -- Auto-suppressed if arg_loc is generated
+                thing_inside }
 
 {- *********************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 296b223c8a..16d9cd05b8 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -31,7 +31,7 @@ module GHC.Tc.Gen.Head
        , tyConOf, tyConOfET, lookupParents, fieldNotInType
        , notSelector, nonBidirectionalErr
 
-       , addExprCtxt, addFunResCtxt ) where
+       , addHeadCtxt, addExprCtxt, addFunResCtxt ) where
 
 import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )
 
@@ -431,12 +431,11 @@ tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
 --
 -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App
 tcInferAppHead (fun,ctxt) args
-  = setSrcSpan (appCtxtLoc ctxt) $
+  = addHeadCtxt ctxt $
     do { mb_tc_fun <- tcInferAppHead_maybe fun args
        ; case mb_tc_fun of
             Just (fun', fun_sigma) -> return (fun', fun_sigma)
-            Nothing -> add_head_ctxt fun args $
-                       tcInfer (tcExpr fun) }
+            Nothing -> tcInfer (tcExpr fun) }
 
 tcInferAppHead_maybe :: HsExpr GhcRn
                      -> [HsExprArg 'TcpRn]
@@ -447,20 +446,23 @@ tcInferAppHead_maybe fun args
   = case fun of
       HsVar _ (L _ nm)          -> Just <$> tcInferId nm
       HsRecSel _ f              -> Just <$> tcInferRecSelId f
-      ExprWithTySig _ e hs_ty   -> add_head_ctxt fun args $
-                                   Just <$> tcExprWithSig e hs_ty
+      ExprWithTySig _ e hs_ty   -> Just <$> tcExprWithSig e hs_ty
       HsOverLit _ lit           -> Just <$> tcInferOverLit lit
       HsSpliceE _ (HsSpliced _ _ (HsSplicedExpr e))
                                 -> tcInferAppHead_maybe e args
       _                         -> return Nothing
 
-add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
--- Don't push an expression context if the arguments are empty,
--- because it has already been pushed by tcExpr
-add_head_ctxt fun args thing_inside
-  | null args = thing_inside
-  | otherwise = addExprCtxt fun thing_inside
-
+addHeadCtxt :: AppCtxt -> TcM a -> TcM a
+addHeadCtxt fun_ctxt thing_inside
+  | not (isGoodSrcSpan fun_loc)   -- noSrcSpan => no arguments
+  = thing_inside                  -- => context is already set
+  | otherwise
+  = setSrcSpan fun_loc $
+    case fun_ctxt of
+      VAExpansion orig _ -> addExprCtxt orig thing_inside
+      VACall {}          -> thing_inside
+  where
+    fun_loc = appCtxtLoc fun_ctxt
 
 {- *********************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index bce78dda31..f7dd7e7a9a 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -31,7 +31,7 @@ module GHC.Tc.Types(
         Env(..),
         TcGblEnv(..), TcLclEnv(..),
         setLclEnvTcLevel, getLclEnvTcLevel,
-        setLclEnvLoc, getLclEnvLoc,
+        setLclEnvLoc, getLclEnvLoc, lclEnvInGeneratedCode,
         IfGblEnv(..), IfLclEnv(..),
         tcVisibleOrphanMods,
         RewriteEnv(..),
@@ -861,6 +861,9 @@ setLclEnvLoc env loc = env { tcl_loc = loc }
 getLclEnvLoc :: TcLclEnv -> RealSrcSpan
 getLclEnvLoc = tcl_loc
 
+lclEnvInGeneratedCode :: TcLclEnv -> Bool
+lclEnvInGeneratedCode = tcl_in_gen_code
+
 type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, SDoc))
         -- Monadic so that we have a chance
         -- to deal with bound type variables just before error
diff --git a/compiler/GHC/Tc/Types.hs-boot b/compiler/GHC/Tc/Types.hs-boot
index 42df1f4bc0..405374a06b 100644
--- a/compiler/GHC/Tc/Types.hs-boot
+++ b/compiler/GHC/Tc/Types.hs-boot
@@ -1,5 +1,6 @@
 module GHC.Tc.Types where
 
+import GHC.Prelude
 import GHC.Tc.Utils.TcType
 import GHC.Types.SrcLoc
 import GHC.Utils.Outputable
@@ -19,3 +20,5 @@ getLclEnvTcLevel :: TcLclEnv -> TcLevel
 
 setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv
 getLclEnvLoc :: TcLclEnv -> RealSrcSpan
+
+lclEnvInGeneratedCode :: TcLclEnv -> Bool
diff --git a/testsuite/tests/dependent/should_fail/T15859.stderr b/testsuite/tests/dependent/should_fail/T15859.stderr
index be25e98708..9779cb5f1a 100644
--- a/testsuite/tests/dependent/should_fail/T15859.stderr
+++ b/testsuite/tests/dependent/should_fail/T15859.stderr
@@ -4,5 +4,6 @@ T15859.hs:9:19: error:
         forall k -> k -> *
       (GHC does not yet support this)
     • In an expression type signature: forall k -> k -> Type
-      In the expression: undefined :: forall k -> k -> Type
       In the expression: (undefined :: forall k -> k -> Type) @Int
+      In an equation for ‘a’:
+          a = (undefined :: forall k -> k -> Type) @Int
diff --git a/testsuite/tests/dependent/should_fail/T15859a.stderr b/testsuite/tests/dependent/should_fail/T15859a.stderr
index 491733c7b9..2d04f8d1fa 100644
--- a/testsuite/tests/dependent/should_fail/T15859a.stderr
+++ b/testsuite/tests/dependent/should_fail/T15859a.stderr
@@ -1,8 +1,8 @@
 
 T15859a.hs:19:26: error:
     • Expected kind ‘k0’, but ‘A’ has kind ‘forall k -> k -> *’
-      Cannot instantiate unification variable ‘k0’
+    • Cannot instantiate unification variable ‘k0’
       with a kind involving polytypes: forall k -> k -> *
     • In the first argument of ‘KindOf’, namely ‘A’
       In an expression type signature: KindOf A
-      In the expression: undefined :: KindOf A
+      In the expression: (undefined :: KindOf A) @Int
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
index 38d9616489..f36e3d9385 100644
--- a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
@@ -1,11 +1,7 @@
-RecordDotSyntaxFail10.hs:40:11:
-     Couldn't match type ‘Int’ with ‘[Char]’
-        arising from a functional dependency between:
-          constraint ‘HasField "quux" Quux String’
-            arising from a use of ‘setField’
-          instance ‘HasField "quux" Quux Int’
-            at RecordDotSyntaxFail10.hs:34:10-33
-     In the second argument of ‘($)’, namely ‘a {foo.bar.baz.quux}’
+
+RecordDotSyntaxFail10.hs:40:11: error:
+    • Couldn't match type ‘Int’ with ‘[Char]’
+    • In the second argument of ‘($)’, namely ‘a {foo.bar.baz.quux}’
       In a stmt of a 'do' block: print $ a {foo.bar.baz.quux}
       In the expression:
         do let a = ...
diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
index 595f32c8b2..1b90621057 100644
--- a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
+++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
@@ -17,7 +17,6 @@ RecordDotSyntaxFail11.hs:8:3: error:
 
 RecordDotSyntaxFail11.hs:8:11: error:
     • No instance for (GHC.Records.HasField "baz" Int a0)
-        arising from a use of ‘GHC.Records.getField’
     • In the second argument of ‘($)’, namely ‘(.foo.bar.baz) a’
       In a stmt of a 'do' block: print $ (.foo.bar.baz) a
       In the expression:
diff --git a/testsuite/tests/parser/should_fail/T20654a.stderr b/testsuite/tests/parser/should_fail/T20654a.stderr
index eb9ed41cd3..81760a572b 100644
--- a/testsuite/tests/parser/should_fail/T20654a.stderr
+++ b/testsuite/tests/parser/should_fail/T20654a.stderr
@@ -8,6 +8,5 @@ T20654a.hs:7:9: error:
           ‘?poly::forall a. a -> a’
             arising from the type signature for:
                            foo :: (?poly::forall a. a -> a) => Int -> Int at T20654a.hs:6:1-48
-    • In the expression: ?poly
-      In the expression: ?poly x
+    • In the expression: ?poly x
       In an equation for ‘foo’: foo x = ?poly x
diff --git a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr
index 285060c0c9..fa77d1d0f7 100644
--- a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr
@@ -12,8 +12,9 @@ SplicesUsed.hs:8:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
                the inferred type of <expression> :: w -> w
                at SplicesUsed.hs:8:14-23
     • In an expression type signature: _a -> _a
-      In the expression: id :: _a -> _a
       In the expression: (id :: _a -> _a) (Just True :: Maybe _)
+      In an equation for ‘maybeBool’:
+          maybeBool = (id :: _a -> _a) (Just True :: Maybe _)
     • Relevant bindings include
         maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1)
 
@@ -81,4 +82,3 @@ SplicesUsed.hs:18:2: warning: [-Wpartial-type-signatures (in -Wdefault)]
                the inferred type of bar :: Bool -> w -> (Bool, w)
                at SplicesUsed.hs:18:2-11
     • In the type signature: bar :: _a -> _b -> (_a, _b)
-
diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr
index 823b1f9e5e..117a8cca0d 100644
--- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr
+++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr
@@ -5,8 +5,8 @@ ExtraConstraintsWildcardInExpressionSignature.hs:5:20: warning: [-Wpartial-type-
                the inferred type of <expression> :: Eq a1 => a1 -> a1 -> Bool
                at ExtraConstraintsWildcardInExpressionSignature.hs:5:20-25
     • In an expression type signature: _ => _
-      In the expression: (==) :: _ => _
       In the expression: ((==) :: _ => _) x y
+      In an equation for ‘foo’: foo x y = ((==) :: _ => _) x y
     • Relevant bindings include
         y :: a
           (bound at ExtraConstraintsWildcardInExpressionSignature.hs:5:7)
@@ -21,8 +21,8 @@ ExtraConstraintsWildcardInExpressionSignature.hs:5:25: warning: [-Wpartial-type-
                the inferred type of <expression> :: Eq a1 => a1 -> a1 -> Bool
                at ExtraConstraintsWildcardInExpressionSignature.hs:5:20-25
     • In an expression type signature: _ => _
-      In the expression: (==) :: _ => _
       In the expression: ((==) :: _ => _) x y
+      In an equation for ‘foo’: foo x y = ((==) :: _ => _) x y
     • Relevant bindings include
         y :: a
           (bound at ExtraConstraintsWildcardInExpressionSignature.hs:5:7)
diff --git a/testsuite/tests/typecheck/should_compile/T14590.stderr b/testsuite/tests/typecheck/should_compile/T14590.stderr
index 4704a7aa01..19a4d72148 100644
--- a/testsuite/tests/typecheck/should_compile/T14590.stderr
+++ b/testsuite/tests/typecheck/should_compile/T14590.stderr
@@ -1,7 +1,8 @@
 
 T14590.hs:4:11: warning: [-Wtyped-holes (in -Wdefault)]
     • Found hole: _ :: Int -> Int -> Int
-    • In the expression: (x `_`) y
+    • In the expression: x `_`
+      In the expression: (x `_`) y
       In an equation for ‘f1’: f1 x y = (x `_`) y
     • Relevant bindings include
         y :: Int (bound at T14590.hs:4:6)
@@ -88,7 +89,8 @@ T14590.hs:4:11: warning: [-Wtyped-holes (in -Wdefault)]
 T14590.hs:5:11: warning: [-Wtyped-holes (in -Wdefault)]
     • Found hole: _a :: Int -> Int -> Int
       Or perhaps ‘_a’ is mis-spelled, or not in scope
-    • In the expression: (x `_a`) y
+    • In the expression: x `_a`
+      In the expression: (x `_a`) y
       In an equation for ‘f2’: f2 x y = (x `_a`) y
     • Relevant bindings include
         y :: Int (bound at T14590.hs:5:6)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail104.stderr b/testsuite/tests/typecheck/should_fail/tcfail104.stderr
index 0d9b338216..3645423c0a 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail104.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail104.stderr
@@ -6,9 +6,11 @@ tcfail104.hs:16:12: error:
         Actual: (Char -> Char) -> Char -> Char
     • In the expression: \ x -> x
       In the expression:
-        if v then (\ (x :: forall a. a -> a) -> x) else (\ x -> x)
-      In the expression:
         (if v then (\ (x :: forall a. a -> a) -> x) else (\ x -> x)) id 'c'
+      In an equation for ‘f3’:
+          f3 v
+            = (if v then (\ (x :: forall a. a -> a) -> x) else (\ x -> x))
+                id 'c'
 
 tcfail104.hs:22:12: error:
     • Couldn't match type: forall a. a -> a
@@ -17,6 +19,8 @@ tcfail104.hs:22:12: error:
         Actual: (forall a. a -> a) -> Char -> Char
     • In the expression: \ (x :: forall a. a -> a) -> x
       In the expression:
-        if v then (\ x -> x) else (\ (x :: forall a. a -> a) -> x)
-      In the expression:
         (if v then (\ x -> x) else (\ (x :: forall a. a -> a) -> x)) id 'c'
+      In an equation for ‘f4’:
+          f4 v
+            = (if v then (\ x -> x) else (\ (x :: forall a. a -> a) -> x))
+                id 'c'
diff --git a/testsuite/tests/typecheck/should_fail/tcfail140.stderr b/testsuite/tests/typecheck/should_fail/tcfail140.stderr
index da0141da67..cbac61f7d0 100644
--- a/testsuite/tests/typecheck/should_fail/tcfail140.stderr
+++ b/testsuite/tests/typecheck/should_fail/tcfail140.stderr
@@ -30,7 +30,7 @@ tcfail140.hs:17:8: error:
     • In the pattern: Just
       The lambda expression ‘\ Just x -> x’ has two value arguments,
         but its type ‘Maybe a -> a’ has only one
-      In the expression: (\ Just x -> x) :: Maybe a -> a
+      In the expression: ((\ Just x -> x) :: Maybe a -> a) (Just 1)
 
 tcfail140.hs:20:1: error:
     • Couldn't match expected type ‘Int’ with actual type ‘p0 -> Bool’