More accurate SrcSpan when reporting redundant constraints

We want an accurate SrcSpan for redundant constraints:

        • Redundant constraint: Eq a
        • In the type signature for:
               f :: forall a. Eq a => a -> ()
      |
    5 | f :: Eq a => a -> ()
      |      ^^^^

This patch adds some plumbing to achieve this

* New data type GHC.Tc.Types.Origin.ReportRedundantConstraints (RRC)

* This RRC value is kept inside
  - FunSigCtxt
  - ExprSigCtxt

* Then, when reporting the error in GHC.Tc.Errors, use this SrcSpan
  to control the error message: GHC.Tc.Errors.warnRedundantConstraints

Quite a lot of files are touched in a boring way.

19 files changed, 204 insertions, 58 deletions

diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index fb52a01c4b..1f972c6425 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -463,9 +463,10 @@ warnRedundantConstraints ctxt env info ev_vars
  | null redundant_evs
  = return ()
 
- | SigSkol {} <- info
+ | SigSkol user_ctxt _ _  <- info
  = setLclEnv env $  -- We want to add "In the type signature for f"
                     -- to the error context, which is a bit tiresome
+   setSrcSpan (redundantConstraintsSpan user_ctxt) $
    addErrCtxt (text "In" <+> ppr info) $
    do { env <- getLclEnv
       ; msg <- mkErrorReport (WarningWithFlag Opt_WarnRedundantConstraints) ctxt env (important doc)
diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs
index b89f5c8a6c..d6b09d6692 100644
--- a/compiler/GHC/Tc/Errors/Hole.hs
+++ b/compiler/GHC/Tc/Errors/Hole.hs
@@ -942,7 +942,7 @@ tcCheckHoleFit (TypedHole {..}) hole_ty ty = discardErrs $
                           -- imp is the innermost implication
                           (imp:_) -> return (ic_tclvl imp)
      ; (wrap, wanted) <- setTcLevel innermost_lvl $ captureConstraints $
-                         tcSubTypeSigma ExprSigCtxt ty hole_ty
+                         tcSubTypeSigma (ExprSigCtxt NoRRC) ty hole_ty
      ; traceTc "Checking hole fit {" empty
      ; traceTc "wanteds are: " $ ppr wanted
      ; if isEmptyWC wanted && isEmptyBag th_relevant_cts
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 10294998c0..386f1959b6 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -230,7 +230,7 @@ tcHsBootSigs binds sigs
     tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
       where
         f (L _ name)
-          = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty
+          = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name NoRRC) hs_ty
                ; return (mkVanillaGlobal name sigma_ty) }
         -- Notice that we make GlobalIds, not LocalIds
     tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 85fd9d51f4..feb984fc26 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -35,7 +35,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExp
 import GHC.Tc.Gen.HsType
 import GHC.Tc.Gen.Pat
 import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
-import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig )
+import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan )
 import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.Unify
@@ -591,7 +591,7 @@ tcInferAmbiguousRecSelId lbl args mb_res_ty
   | arg1 : _ <- dropWhile (not . isVisibleArg) args -- A value arg is first
   , EValArg { eva_arg = ValArg (L _ arg) } <- arg1
   , Just sig_ty <- obviousSig arg  -- A type sig on the arg disambiguates
-  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
+  = do { sig_tc_ty <- tcHsSigWcType (ExprSigCtxt NoRRC) sig_ty
        ; finish_ambiguous_selector lbl sig_tc_ty }
 
   | Just res_ty <- mb_res_ty
@@ -718,20 +718,21 @@ tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)
 tcExprWithSig expr hs_ty
   = do { sig_info <- checkNoErrs $  -- Avoid error cascade
                      tcUserTypeSig loc hs_ty Nothing
-       ; (expr', poly_ty) <- tcExprSig expr sig_info
+       ; (expr', poly_ty) <- tcExprSig ctxt expr sig_info
        ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) }
   where
     loc = getLocA (dropWildCards hs_ty)
+    ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty)
 
-tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)
-tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
+tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)
+tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
   = setSrcSpan loc $   -- Sets the location for the implication constraint
     do { let poly_ty = idType poly_id
-       ; (wrap, expr') <- tcSkolemiseScoped ExprSigCtxt poly_ty $ \rho_ty ->
+       ; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \rho_ty ->
                           tcCheckMonoExprNC expr rho_ty
        ; return (mkLHsWrap wrap expr', poly_ty) }
 
-tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })
+tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc })
   = setSrcSpan loc $   -- Sets the location for the implication constraint
     do { (tclvl, wanted, (expr', sig_inst))
              <- pushLevelAndCaptureConstraints  $
@@ -761,7 +762,7 @@ tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })
                  then return idHsWrapper  -- Fast path; also avoids complaint when we infer
                                           -- an ambiguous type and have AllowAmbiguousType
                                           -- e..g infer  x :: forall a. F a -> Int
-                 else tcSubTypeSigma ExprSigCtxt inferred_sigma my_sigma
+                 else tcSubTypeSigma (ExprSigCtxt NoRRC) inferred_sigma my_sigma
 
        ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)
        ; let poly_wrap = wrap
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index bf836e5602..5a7fb93f48 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -339,7 +339,7 @@ we promote the metavariable to level 1. This is all done in kindGeneralizeNone.
 funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt
 -- Returns FunSigCtxt, with no redundant-context-reporting,
 -- form a list of located names
-funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False
+funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 NoRRC
 funsSigCtxt []              = panic "funSigCtxt"
 
 addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index 4a25ffa447..5a6560864d 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -15,6 +15,7 @@ module GHC.Tc.Gen.Sig(
 
        isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,
        completeSigPolyId_maybe, isCompleteHsSig,
+       lhsSigWcTypeContextSpan, lhsSigTypeContextSpan,
 
        tcTySigs, tcUserTypeSig, completeSigFromId,
        tcInstSig,
@@ -180,8 +181,8 @@ tcTySigs hs_sigs
 
 tcTySig :: LSig GhcRn -> TcM [TcSigInfo]
 tcTySig (L _ (IdSig _ id))
-  = do { let ctxt = FunSigCtxt (idName id) False
-                    -- False: do not report redundant constraints
+  = do { let ctxt = FunSigCtxt (idName id) NoRRC
+                    -- NoRRC: do not report redundant constraints
                     -- The user has no control over the signature!
              sig = completeSigFromId ctxt id
        ; return [TcIdSig sig] }
@@ -216,7 +217,7 @@ tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name
 -- Nothing => Expression type signature   <expr> :: type
 tcUserTypeSig loc hs_sig_ty mb_name
   | isCompleteHsSig hs_sig_ty
-  = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty
+  = do { sigma_ty <- tcHsSigWcType ctxt_no_rrc hs_sig_ty
        ; traceTc "tcuser" (ppr sigma_ty)
        ; return $
          CompleteSig { sig_bndr  = mkLocalId name Many sigma_ty
@@ -225,26 +226,44 @@ tcUserTypeSig loc hs_sig_ty mb_name
                                    -- anything, it is a top-level
                                    -- definition. Which are all unrestricted in
                                    -- the current implementation.
-                     , sig_ctxt  = ctxt_T
+                     , sig_ctxt  = ctxt_rrc  -- Report redundant constraints
                      , sig_loc   = loc } }
                        -- Location of the <type> in   f :: <type>
 
   -- Partial sig with wildcards
   | otherwise
   = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty
-                       , sig_ctxt = ctxt_F, sig_loc = loc })
+                       , sig_ctxt = ctxt_no_rrc, sig_loc = loc })
   where
     name   = case mb_name of
                Just n  -> n
                Nothing -> mkUnboundName (mkVarOcc "<expression>")
-    ctxt_F = case mb_name of
-               Just n  -> FunSigCtxt n False
-               Nothing -> ExprSigCtxt
-    ctxt_T = case mb_name of
-               Just n  -> FunSigCtxt n True
-               Nothing -> ExprSigCtxt
 
+    ctxt_rrc    = ctxt_fn (lhsSigWcTypeContextSpan hs_sig_ty)
+    ctxt_no_rrc = ctxt_fn NoRRC
 
+    ctxt_fn :: ReportRedundantConstraints -> UserTypeCtxt
+    ctxt_fn rcc = case mb_name of
+               Just n  -> FunSigCtxt n rcc
+               Nothing -> ExprSigCtxt rcc
+
+lhsSigWcTypeContextSpan :: LHsSigWcType GhcRn -> ReportRedundantConstraints
+-- | Find the location of the top-level context of a HsType.  For example:
+--
+-- @
+--   forall a b. (Eq a, Ord b) => blah
+--               ^^^^^^^^^^^^^
+-- @
+-- If there is none, return Nothing
+lhsSigWcTypeContextSpan (HsWC { hswc_body = sigType }) = lhsSigTypeContextSpan sigType
+
+lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints
+lhsSigTypeContextSpan (L _ HsSig { sig_body = sig_ty }) = go sig_ty
+  where
+    go (L _ (HsQualTy { hst_ctxt = Just (L span _) })) = WantRRC $ locA span -- Found it!
+    go (L _ (HsForAllTy { hst_body = hs_ty })) = go hs_ty  -- Look under foralls
+    go (L _ (HsParTy _ hs_ty)) = go hs_ty  -- Look under parens
+    go _ = NoRRC  -- Did not find it
 
 completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo
 -- Used for instance methods and record selectors
@@ -757,8 +776,8 @@ tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
     spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag)
 
     tc_one hs_ty
-      = do { spec_ty <- tcHsSigType   (FunSigCtxt name False) hs_ty
-           ; wrap    <- tcSpecWrapper (FunSigCtxt name True)  poly_ty spec_ty
+      = do { spec_ty <- tcHsSigType   (FunSigCtxt name NoRRC) hs_ty
+           ; wrap    <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty
            ; return (SpecPrag poly_id wrap inl) }
 
 tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index e906dd267f..777086343b 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -1781,7 +1781,7 @@ checkMainType tcg_env
             [main_gre] ->
 
     do { let main_name = greMangledName main_gre
-             ctxt      = FunSigCtxt main_name False
+             ctxt      = FunSigCtxt main_name NoRRC
        ; main_id   <- tcLookupId main_name
        ; (io_ty,_) <- getIOType
        ; (_, lie)  <- captureTopConstraints       $
@@ -1914,7 +1914,7 @@ setMainCtxt main_name io_ty thing_inside
     checkConstraints skol_info [] []  $  -- Builds an implication if necessary
     thing_inside                         -- e.g. with -fdefer-type-errors
   where
-    skol_info = SigSkol (FunSigCtxt main_name False) io_ty []
+    skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty []
     main_ctxt = text "When checking the type of the"
                 <+> ppMainFn (nameOccName main_name)
 
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index d4e9003b72..5e79a75472 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -2042,9 +2042,9 @@ checkBadTelescope (Implic { ic_info  = info
 warnRedundantGivens :: SkolemInfo -> Bool
 warnRedundantGivens (SigSkol ctxt _ _)
   = case ctxt of
-       FunSigCtxt _ warn_redundant -> warn_redundant
-       ExprSigCtxt                 -> True
-       _                           -> False
+       FunSigCtxt _ rrc -> reportRedundantConstraints rrc
+       ExprSigCtxt rrc  -> reportRedundantConstraints rrc
+       _                -> False
 
   -- To think about: do we want to report redundant givens for
   -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21.
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 41767eded1..076c0c0ee0 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -4560,7 +4560,7 @@ checkValidClass cls
         ; check_dm ctxt sel_id cls_pred tau2 dm
         }
         where
-          ctxt    = FunSigCtxt op_name True -- Report redundant class constraints
+          ctxt    = FunSigCtxt op_name (WantRRC (getSrcSpan cls)) -- Report redundant class constraints
           op_name = idName sel_id
           op_ty   = idType sel_id
           (_,cls_pred,tau1) = tcSplitMethodTy op_ty
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 491e657811..72de8f0652 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -282,8 +282,8 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
                              -- NB: the binding is always a FunBind
 
              warn_redundant = case dm_spec of
-                                GenericDM {} -> True
-                                VanillaDM    -> False
+                                GenericDM {} -> lhsSigTypeContextSpan hs_ty
+                                VanillaDM    -> NoRRC
                 -- For GenericDM, warn if the user specifies a signature
                 -- with redundant constraints; but not for VanillaDM, where
                 -- the default method may well be 'error' or something
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index c36ef7d794..b9a4e17bf7 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -1893,9 +1893,9 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
              <- setSrcSpan (getLocA hs_sig_ty) $
                 do { inst_sigs <- xoptM LangExt.InstanceSigs
                    ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)
-                   ; sig_ty  <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty
+                   ; let ctxt = FunSigCtxt sel_name NoRRC
+                   ; sig_ty  <- tcHsSigType ctxt hs_sig_ty
                    ; let local_meth_ty = idType local_meth_id
-                         ctxt = FunSigCtxt sel_name False
                                 -- False <=> do not report redundant constraints when
                                 --           checking instance-sig <= class-meth-sig
                                 -- The instance-sig is the focus here; the class-meth-sig
@@ -1905,8 +1905,8 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
                    ; return (sig_ty, hs_wrap) }
 
        ; inner_meth_name <- newName (nameOccName sel_name)
-       ; let ctxt = FunSigCtxt sel_name True
-                    -- True <=> check for redundant constraints in the
+       ; let ctxt = FunSigCtxt sel_name (lhsSigTypeContextSpan hs_sig_ty)
+                    -- WantRCC <=> check for redundant constraints in the
                     --          user-specified instance signature
              inner_meth_id  = mkLocalId inner_meth_name Many sig_ty
              inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
@@ -1929,8 +1929,8 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
                           , abs_sig = True }) }
 
   | otherwise  -- No instance signature
-  = do { let ctxt = FunSigCtxt sel_name False
-                    -- False <=> don't report redundant constraints
+  = do { let ctxt = FunSigCtxt sel_name NoRRC
+                    -- NoRRC <=> don't report redundant constraints
                     -- The signature is not under the users control!
              tc_sig = completeSigFromId ctxt local_meth_id
               -- Absent a type sig, there are no new scoped type variables here
@@ -1948,7 +1948,6 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
     no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;
                                 -- they are all for meth_id
 
-
 ------------------------
 mkMethIds :: Class -> [TcTyVar] -> [EvVar]
           -> [TcType] -> Id -> TcM (TcId, TcId)
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 4ddb0ee000..668dbb024c 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -9,6 +9,8 @@
 module GHC.Tc.Types.Origin (
   -- UserTypeCtxt
   UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe,
+  ReportRedundantConstraints(..), reportRedundantConstraints,
+  redundantConstraintsSpan,
 
   -- SkolemInfo
   SkolemInfo(..), pprSigSkolInfo, pprSkolInfo,
@@ -61,17 +63,16 @@ data UserTypeCtxt
   = FunSigCtxt      -- Function type signature, when checking the type
                     -- Also used for types in SPECIALISE pragmas
        Name              -- Name of the function
-       Bool              -- True <=> report redundant constraints
-                            -- This is usually True, but False for
-                            --   * Record selectors (not important here)
-                            --   * Class and instance methods.  Here
-                            --     the code may legitimately be more
-                            --     polymorphic than the signature
-                            --     generated from the class
-                            --     declaration
+       ReportRedundantConstraints
+         -- This is usually 'WantRCC', but 'NoRCC' for
+         --   * Record selectors (not important here)
+         --   * Class and instance methods.  Here the code may legitimately
+         --     be more polymorphic than the signature generated from the
+         --     class declaration
 
   | InfSigCtxt Name     -- Inferred type for function
   | ExprSigCtxt         -- Expression type signature
+      ReportRedundantConstraints
   | KindSigCtxt         -- Kind signature
   | StandaloneKindSigCtxt  -- Standalone kind signature
        Name                -- Name of the type/class
@@ -110,6 +111,23 @@ data UserTypeCtxt
   | TySynKindCtxt Name  -- The kind of the RHS of a type synonym
   | TyFamResKindCtxt Name   -- The result kind of a type family
 
+-- | Report Redundant Constraints.
+data ReportRedundantConstraints
+  = NoRRC            -- ^ Don't report redundant constraints
+  | WantRRC SrcSpan  -- ^ Report redundant constraints, and here
+                     -- is the SrcSpan for the constraints
+                     -- E.g. f :: (Eq a, Ord b) => blah
+                     -- The span is for the (Eq a, Ord b)
+
+reportRedundantConstraints :: ReportRedundantConstraints -> Bool
+reportRedundantConstraints NoRRC        = False
+reportRedundantConstraints (WantRRC {}) = True
+
+redundantConstraintsSpan :: UserTypeCtxt -> SrcSpan
+redundantConstraintsSpan (FunSigCtxt _ (WantRRC span)) = span
+redundantConstraintsSpan (ExprSigCtxt (WantRRC span))  = span
+redundantConstraintsSpan _ = noSrcSpan
+
 {-
 -- Notes re TySynCtxt
 -- We allow type synonyms that aren't types; e.g.  type List = []
@@ -127,7 +145,7 @@ pprUserTypeCtxt :: UserTypeCtxt -> SDoc
 pprUserTypeCtxt (FunSigCtxt n _)  = text "the type signature for" <+> quotes (ppr n)
 pprUserTypeCtxt (InfSigCtxt n)    = text "the inferred type for" <+> quotes (ppr n)
 pprUserTypeCtxt (RuleSigCtxt n)   = text "the type signature for" <+> quotes (ppr n)
-pprUserTypeCtxt ExprSigCtxt       = text "an expression type signature"
+pprUserTypeCtxt (ExprSigCtxt _)   = text "an expression type signature"
 pprUserTypeCtxt KindSigCtxt       = text "a kind signature"
 pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n)
 pprUserTypeCtxt TypeAppCtxt       = text "a type argument"
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 173a8e68cf..91f1bcdbe7 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -352,7 +352,7 @@ checkValidType ctxt ty
                  RuleSigCtxt _  -> rank1
                  TySynCtxt _    -> rank0
 
-                 ExprSigCtxt    -> rank1
+                 ExprSigCtxt {} -> rank1
                  KindSigCtxt    -> rank1
                  StandaloneKindSigCtxt{} -> rank1
                  TypeAppCtxt | impred_flag -> ArbitraryRank
@@ -1351,7 +1351,7 @@ okIPCtxt :: UserTypeCtxt -> Bool
   -- See Note [Implicit parameters in instance decls]
 okIPCtxt (FunSigCtxt {})        = True
 okIPCtxt (InfSigCtxt {})        = True
-okIPCtxt ExprSigCtxt            = True
+okIPCtxt (ExprSigCtxt {})       = True
 okIPCtxt TypeAppCtxt            = True
 okIPCtxt PatSigCtxt             = True
 okIPCtxt GenSigCtxt             = True
diff --git a/testsuite/tests/typecheck/should_compile/T10632.stderr b/testsuite/tests/typecheck/should_compile/T10632.stderr
index 1733f0ae7a..44a8fb7b6f 100644
--- a/testsuite/tests/typecheck/should_compile/T10632.stderr
+++ b/testsuite/tests/typecheck/should_compile/T10632.stderr
@@ -1,5 +1,5 @@
 
-T10632.hs:4:1: warning: [-Wredundant-constraints]
+T10632.hs:4:6: warning: [-Wredundant-constraints]
     • Redundant constraint: ?file1::String
     • In the type signature for:
            f :: (?file1::String) => IO ()
diff --git a/testsuite/tests/typecheck/should_compile/T9939.stderr b/testsuite/tests/typecheck/should_compile/T9939.stderr
index 2ebc927006..3d4c964a15 100644
--- a/testsuite/tests/typecheck/should_compile/T9939.stderr
+++ b/testsuite/tests/typecheck/should_compile/T9939.stderr
@@ -1,20 +1,20 @@
 
-T9939.hs:6:1: warning: [-Wredundant-constraints]
+T9939.hs:6:7: warning: [-Wredundant-constraints]
     • Redundant constraint: Eq a
     • In the type signature for:
            f1 :: forall a. (Eq a, Ord a) => a -> a -> Bool
 
-T9939.hs:10:1: warning: [-Wredundant-constraints]
+T9939.hs:10:7: warning: [-Wredundant-constraints]
     • Redundant constraint: Eq a
     • In the type signature for:
            f2 :: forall a. (Eq a, Ord a) => a -> a -> Bool
 
-T9939.hs:14:1: warning: [-Wredundant-constraints]
+T9939.hs:14:7: warning: [-Wredundant-constraints]
     • Redundant constraint: Eq b
     • In the type signature for:
            f3 :: forall a b. (Eq a, a ~ b, Eq b) => a -> b -> Bool
 
-T9939.hs:21:1: warning: [-Wredundant-constraints]
+T9939.hs:21:7: warning: [-Wredundant-constraints]
     • Redundant constraint: Eq a
     • In the type signature for:
            f4 :: forall a b. (Eq a, Eq b) => a -> b -> Equal a b -> Bool
diff --git a/testsuite/tests/warnings/should_compile/PluralS.stderr b/testsuite/tests/warnings/should_compile/PluralS.stderr
index 53ed5c4633..0276c3a59d 100644
--- a/testsuite/tests/warnings/should_compile/PluralS.stderr
+++ b/testsuite/tests/warnings/should_compile/PluralS.stderr
@@ -14,12 +14,12 @@ PluralS.hs:17:24: warning: [-Wtype-defaults (in -Wall)]
       In an equation for ‘defaultingNumAndShow’:
           defaultingNumAndShow = show 123
 
-PluralS.hs:23:1: warning: [-Wredundant-constraints]
+PluralS.hs:23:17: warning: [-Wredundant-constraints]
     • Redundant constraint: Num a
     • In the type signature for:
            redundantNum :: forall a. (Num a, Num a) => a
 
-PluralS.hs:26:1: warning: [-Wredundant-constraints]
+PluralS.hs:26:22: warning: [-Wredundant-constraints]
     • Redundant constraints: (Show a, Num a, Eq a, Eq a)
     • In the type signature for:
            redundantMultiple :: forall a.
diff --git a/testsuite/tests/warnings/should_compile/T19296.hs b/testsuite/tests/warnings/should_compile/T19296.hs
new file mode 100644
index 0000000000..ef4ed74bce
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T19296.hs
@@ -0,0 +1,40 @@
+{-# OPTIONS_GHC -Wredundant-constraints -dsuppress-uniques #-}
+{-# LANGUAGE DefaultSignatures, InstanceSigs #-}
+module M ( f ) where
+
+-- Redundant constraint
+f :: Eq a => a -> ()
+f _ = ()
+
+-- Redundant constraint in expression signature
+g _ = (\x -> ()) :: Eq a => a -> ()
+
+-- GHC highlights more than necessary
+h :: (Eq a, Ord b) => a -> b -> b
+h _ b
+    | b <= b = b
+    | otherwise = b
+
+-- Redundant constraint in specialize pragma.
+-- Also generates an unrelated warning:
+-- > Forall'd constraint ‘Eq a’ is not bound in RULE lhs
+{-# SPECIALISE spec :: Eq a => a -> Int -> Int #-}
+
+spec :: Ord b => a -> b -> b
+spec _ b
+    | b <= b = b
+    | otherwise = b
+
+class Foo a where
+    foo :: [a]
+    -- Redundant constraint in default method
+    default foo :: Show a => [a]
+    foo = []
+
+class Bar a where
+    bar :: Ord b => a -> b -> a
+
+instance Bar Int where
+    -- Redundant Constraint in Instance Signature
+    bar :: (Eq b, Ord b) => Int -> b -> Int
+    bar n _ = n
diff --git a/testsuite/tests/warnings/should_compile/T19296.stderr b/testsuite/tests/warnings/should_compile/T19296.stderr
new file mode 100644
index 0000000000..e76c0cbbef
--- /dev/null
+++ b/testsuite/tests/warnings/should_compile/T19296.stderr
@@ -0,0 +1,65 @@
+
+T19296.hs:6:6: warning: [-Wredundant-constraints]
+    • Redundant constraint: Eq a
+    • In the type signature for:
+           f :: forall a. Eq a => a -> ()
+  |
+6 | f :: Eq a => a -> ()
+  |      ^^^^
+
+T19296.hs:10:21: warning: [-Wredundant-constraints]
+    • Redundant constraint: Eq a
+    • In an expression type signature:
+           forall a1. Eq a1 => a1 -> ()
+      In the expression: (\ x -> ()) :: Eq a => a -> ()
+      In an equation for ‘g’: g _ = (\ x -> ()) :: Eq a => a -> ()
+   |
+10 | g _ = (\x -> ()) :: Eq a => a -> ()
+   |                     ^^^^
+
+T19296.hs:13:6: warning: [-Wredundant-constraints]
+    • Redundant constraint: Eq a
+    • In the type signature for:
+           h :: forall a b. (Eq a, Ord b) => a -> b -> b
+   |
+13 | h :: (Eq a, Ord b) => a -> b -> b
+   |      ^^^^^^^^^^^^^
+
+T19296.hs:21:1: warning:
+    Forall'd constraint ‘Eq a’ is not bound in RULE lhs
+      Orig bndrs: [a, $dEq]
+      Orig lhs: let {
+                  $dOrd :: Ord Int
+                  [LclId]
+                  $dOrd = GHC.Classes.$fOrdInt } in
+                spec @Int @a $dOrd
+      optimised lhs: spec @Int @a $dOrd
+   |
+21 | {-# SPECIALISE spec :: Eq a => a -> Int -> Int #-}
+   | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+T19296.hs:21:24: warning: [-Wredundant-constraints]
+    • Redundant constraint: Eq a
+    • In the type signature for:
+           spec :: forall a. Eq a => a -> Int -> Int
+      In the pragma: {-# SPECIALISE spec :: Eq a => a -> Int -> Int #-}
+   |
+21 | {-# SPECIALISE spec :: Eq a => a -> Int -> Int #-}
+   |                        ^^^^
+
+T19296.hs:31:20: warning: [-Wredundant-constraints]
+    • Redundant constraint: Show a
+    • In the type signature for:
+           foo :: Show a => [a]
+   |
+31 |     default foo :: Show a => [a]
+   |                    ^^^^^^
+
+T19296.hs:39:12: warning: [-Wredundant-constraints]
+    • Redundant constraints: (Eq b, Ord b)
+    • In the type signature for:
+           bar :: forall b. (Eq b, Ord b) => Int -> b -> Int
+      In the instance declaration for ‘Bar Int’
+   |
+39 |     bar :: (Eq b, Ord b) => Int -> b -> Int
+   |            ^^^^^^^^^^^^^
diff --git a/testsuite/tests/warnings/should_compile/all.T b/testsuite/tests/warnings/should_compile/all.T
index f1739aebc3..1201a10f19 100644
--- a/testsuite/tests/warnings/should_compile/all.T
+++ b/testsuite/tests/warnings/should_compile/all.T
@@ -43,3 +43,6 @@ test('T19564a', normal, compile, [''])
 test('T19564b', normal, compile, [''])
 test('T19564c', normal, compile, [''])
 test('T19564d', normal, compile, [''])
+# When warning about redundant constraints, test only Function context is highlighted by caret diagnostics
+# Also, suppress uniques as one of the warnings is unstable in CI, otherwise.
+test('T19296', normal, compile, ['-fdiagnostics-show-caret -Wredundant-constraints -dsuppress-uniques'])