Use transSuperClasses in TcErrors
[ghc.git] / compiler / typecheck / TcErrors.hs
index 1df6cd6..3f0f82c 100644 (file)
@@ -1,4 +1,6 @@
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module TcErrors(
        reportUnsolved, reportAllUnsolved, warnAllUnsolved,
@@ -20,7 +22,6 @@ import TcType
 import RnUnbound ( unknownNameSuggestions )
 import Type
 import TyCoRep
-import Kind
 import Unify            ( tcMatchTys )
 import Module
 import FamInst
@@ -37,7 +38,7 @@ import HsBinds ( PatSynBind(..) )
 import Name
 import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv
                , mkRdrUnqual, isLocalGRE, greSrcSpan )
-import PrelNames ( typeableClassName, hasKey, liftedRepDataConKey, tYPETyConKey )
+import PrelNames ( typeableClassName )
 import Id
 import Var
 import VarSet
@@ -65,7 +66,7 @@ import qualified Data.Set as Set
 
 import {-# SOURCE #-} TcHoleErrors ( findValidHoleFits )
 
-import Data.Semigroup   ( Semigroup )
+-- import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
 
 
@@ -147,8 +148,9 @@ reportUnsolved wanted
                                 | warn_out_of_scope      = HoleWarn
                                 | otherwise              = HoleDefer
 
-       ; report_unsolved binds_var type_errors expr_holes
-          type_holes out_of_scope_holes wanted
+       ; report_unsolved type_errors expr_holes
+                         type_holes out_of_scope_holes
+                         binds_var wanted
 
        ; ev_binds <- getTcEvBindsMap binds_var
        ; return (evBindMapBinds ev_binds)}
@@ -163,8 +165,8 @@ reportUnsolved wanted
 reportAllUnsolved :: WantedConstraints -> TcM ()
 reportAllUnsolved wanted
   = do { ev_binds <- newNoTcEvBinds
-       ; report_unsolved ev_binds TypeError
-                         HoleError HoleError HoleError wanted }
+       ; report_unsolved TypeError HoleError HoleError HoleError
+                         ev_binds wanted }
 
 -- | Report all unsolved goals as warnings (but without deferring any errors to
 -- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in
@@ -172,26 +174,26 @@ reportAllUnsolved wanted
 warnAllUnsolved :: WantedConstraints -> TcM ()
 warnAllUnsolved wanted
   = do { ev_binds <- newTcEvBinds
-       ; report_unsolved ev_binds (TypeWarn NoReason)
-                         HoleWarn HoleWarn HoleWarn wanted }
+       ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn
+                         ev_binds wanted }
 
 -- | Report unsolved goals as errors or warnings.
-report_unsolved :: EvBindsVar        -- cec_binds
-                -> TypeErrorChoice   -- Deferred type errors
+report_unsolved :: TypeErrorChoice   -- Deferred type errors
                 -> HoleChoice        -- Expression holes
                 -> HoleChoice        -- Type holes
                 -> HoleChoice        -- Out of scope holes
+                -> EvBindsVar        -- cec_binds
                 -> WantedConstraints -> TcM ()
-report_unsolved mb_binds_var type_errors expr_holes
-    type_holes out_of_scope_holes wanted
+report_unsolved type_errors expr_holes
+    type_holes out_of_scope_holes binds_var wanted
   | isEmptyWC wanted
   = return ()
   | otherwise
-  = do { traceTc "reportUnsolved warning/error settings:" $
-           vcat [ text "type errors:" <+> ppr type_errors
-                , text "expr holes:" <+> ppr expr_holes
-                , text "type holes:" <+> ppr type_holes
-                , text "scope holes:" <+> ppr out_of_scope_holes ]
+  = do { traceTc "reportUnsolved {" $
+         vcat [ text "type errors:" <+> ppr type_errors
+              , text "expr holes:" <+> ppr expr_holes
+              , text "type holes:" <+> ppr type_holes
+              , text "scope holes:" <+> ppr out_of_scope_holes ]
        ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
 
        ; wanted <- zonkWC wanted   -- Zonk to reveal all information
@@ -213,12 +215,18 @@ report_unsolved mb_binds_var type_errors expr_holes
                             , cec_expr_holes = expr_holes
                             , cec_type_holes = type_holes
                             , cec_out_of_scope_holes = out_of_scope_holes
-                            , cec_suppress = False -- See Note [Suppressing error messages]
+                            , cec_suppress = insolubleWC wanted
+                                 -- See Note [Suppressing error messages]
+                                 -- Suppress low-priority errors if there
+                                 -- are insolule errors anywhere;
+                                 -- See Trac #15539 and c.f. setting ic_status
+                                 -- in TcSimplify.setImplicationStatus
                             , cec_warn_redundant = warn_redundant
-                            , cec_binds    = mb_binds_var }
+                            , cec_binds    = binds_var }
 
        ; tc_lvl <- getTcLevel
-       ; reportWanteds err_ctxt tc_lvl wanted }
+       ; reportWanteds err_ctxt tc_lvl wanted
+       ; traceTc "reportUnsolved }" empty }
 
 --------------------------------------------
 --      Internal functions
@@ -387,7 +395,7 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope
                                  , ic_given = given
                                  , ic_wanted = wanted, ic_binds = evb
                                  , ic_status = status, ic_info = info
-                                 , ic_env = tcl_env, ic_tclvl = tc_lvl })
+                                 , ic_tclvl = tc_lvl })
   | BracketSkol <- info
   , not insoluble
   = return ()        -- For Template Haskell brackets report only
@@ -402,13 +410,14 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope
          warnRedundantConstraints ctxt' tcl_env info' dead_givens
        ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs }
   where
+    tcl_env      = implicLclEnv implic
     insoluble    = isInsolubleStatus status
-    (env1, tvs') = mapAccumL tidyTyCoVarBndr (cec_tidy ctxt) tvs
+    (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs
     info'        = tidySkolemInfo env1 info
     implic' = implic { ic_skols = tvs'
                      , ic_given = map (tidyEvVar env1) given
                      , ic_info  = info' }
-    ctxt1 | NoEvBindsVar{} <- evb    = noDeferredBindings ctxt
+    ctxt1 | CoEvBindsVar{} <- evb    = noDeferredBindings ctxt
           | otherwise                = ctxt
           -- If we go inside an implication that has no term
           -- evidence (e.g. unifying under a forall), we can't defer
@@ -459,12 +468,17 @@ warnRedundantConstraints ctxt env info ev_vars
    doc = text "Redundant constraint" <> plural redundant_evs <> colon
          <+> pprEvVarTheta redundant_evs
 
-   redundant_evs = case info of -- See Note [Redundant constraints in instance decls]
-                     InstSkol -> filterOut improving ev_vars
-                     _        -> ev_vars
+   redundant_evs =
+       filterOut is_type_error $
+       case info of -- See Note [Redundant constraints in instance decls]
+         InstSkol -> filterOut (improving . idType) ev_vars
+         _        -> ev_vars
 
-   improving ev_var = any isImprovementPred $
-                      transSuperClasses (idType ev_var)
+   -- See #15232
+   is_type_error = isJust . userTypeError_maybe . idType
+
+   improving pred -- (transSuperClasses p) does not include p
+     = any isImprovementPred (pred : transSuperClasses pred)
 
 reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TcTyVar] -> TcM ()
 reportBadTelescope ctxt env (Just telescope) skols
@@ -475,7 +489,7 @@ reportBadTelescope ctxt env (Just telescope) skols
                 text "are out of dependency order. Perhaps try this ordering:")
              2 (pprTyVars sorted_tvs)
 
-    sorted_tvs = toposortTyVars skols
+    sorted_tvs = scopedSort skols
 
 reportBadTelescope _ _ Nothing skols
   = pprPanic "reportBadTelescope" (ppr skols)
@@ -533,7 +547,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics })
     -- report1: ones that should *not* be suppresed by
     --          an insoluble somewhere else in the tree
     -- It's crucial that anything that is considered insoluble
-    -- (see TcRnTypes.insolubleWantedCt) is caught here, otherwise
+    -- (see TcRnTypes.insolubleCt) is caught here, otherwise
     -- we might suppress its error message, and proceed on past
     -- type checking to get a Lint error later
     report1 = [ ("Out of scope", is_out_of_scope,    True,  mkHoleReporter tidy_cts)
@@ -589,7 +603,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics })
 
     is_user_type_error ct _ = isUserTypeErrorCt ct
 
-    is_homo_equality _ (EqPred _ ty1 ty2) = typeKind ty1 `tcEqType` typeKind ty2
+    is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2
     is_homo_equality _ _                  = False
 
     is_equality _ (EqPred {}) = True
@@ -604,22 +618,28 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics })
     is_irred _ (IrredPred {}) = True
     is_irred _ _              = False
 
-    given_eq_spec = case find_gadt_match (cec_encl ctxt) of
-       Just imp -> ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter imp)
-       Nothing  -> ("insoluble1b", is_given_eq, False, ignoreErrorReporter)
-                  -- False means don't suppress subsequent errors
-                  -- Reason: we don't report all given errors
-                  --         (see mkGivenErrorReporter), and we should only suppress
-                  --         subsequent errors if we actually report this one!
-                  --         Trac #13446 is an example
-
-    find_gadt_match [] = Nothing
-    find_gadt_match (implic : implics)
+    given_eq_spec  -- See Note [Given errors]
+      | has_gadt_match (cec_encl ctxt)
+      = ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter)
+      | otherwise
+      = ("insoluble1b", is_given_eq, False, ignoreErrorReporter)
+          -- False means don't suppress subsequent errors
+          -- Reason: we don't report all given errors
+          --         (see mkGivenErrorReporter), and we should only suppress
+          --         subsequent errors if we actually report this one!
+          --         Trac #13446 is an example
+
+    -- See Note [Given errors]
+    has_gadt_match [] = False
+    has_gadt_match (implic : implics)
       | PatSkol {} <- ic_info implic
       , not (ic_no_eqs implic)
-      = Just implic
+      , wopt Opt_WarnInaccessibleCode (implicDynFlags implic)
+          -- Don't bother doing this if -Winaccessible-code isn't enabled.
+          -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls.
+      = True
       | otherwise
-      = find_gadt_match implics
+      = has_gadt_match implics
 
 ---------------
 isSkolemTy :: TcLevel -> Type -> Bool
@@ -627,8 +647,8 @@ isSkolemTy :: TcLevel -> Type -> Bool
 isSkolemTy tc_lvl ty
   | Just tv <- getTyVar_maybe ty
   =  isSkolemTyVar tv
-  || (isSigTyVar tv && isTouchableMetaTyVar tc_lvl tv)
-     -- The last case is for touchable SigTvs
+  || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv)
+     -- The last case is for touchable TyVarTvs
      -- we postpone untouchables to a latter test (too obscure)
 
   | otherwise
@@ -688,14 +708,17 @@ mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
                             Nothing  -> pprPanic "mkUserTypeError" (ppr ct)
 
 
-mkGivenErrorReporter :: Implication -> Reporter
+mkGivenErrorReporter :: Reporter
 -- See Note [Given errors]
-mkGivenErrorReporter implic ctxt cts
+mkGivenErrorReporter ctxt cts
   = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
        ; dflags <- getDynFlags
-       ; let ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))
+       ; let (implic:_) = cec_encl ctxt
+                 -- Always non-empty when mkGivenErrorReporter is called
+             ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (implicLclEnv implic))
                    -- For given constraints we overwrite the env (and hence src-loc)
-                  -- with one from the implication.  See Note [Inaccessible code]
+                   -- with one from the immediately-enclosing implication.
+                   -- See Note [Inaccessible code]
 
              inaccessible_msg = hang (text "Inaccessible code in")
                                    2 (ppr (ic_info implic))
@@ -706,7 +729,7 @@ mkGivenErrorReporter implic ctxt cts
                              Nothing ty1 ty2
 
        ; traceTc "mkGivenErrorReporter" (ppr ct)
-       ; maybeReportError ctxt err }
+       ; reportWarning (Reason Opt_WarnInaccessibleCode) err }
   where
     (ct : _ )  = cts    -- Never empty
     (ty1, ty2) = getEqPredTys (ctPred ct)
@@ -748,7 +771,7 @@ which arguably is OK.  It's more debatable for
 but it's tricky to distinguish these cases so we don't report
 either.
 
-The bottom line is this: find_gadt_match looks for an enclosing
+The bottom line is this: has_gadt_match looks for an enclosing
 pattern match which binds some equality constraints.  If we
 find one, we report the insoluble Given.
 -}
@@ -864,11 +887,11 @@ addDeferredBinding ctxt err ct
 
        ; case dest of
            EvVarDest evar
-             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar (EvExpr err_tm)
+             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm
            HoleDest hole
              -> do { -- See Note [Deferred errors for coercion holes]
                      let co_var = coHoleCoVar hole
-                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var (EvExpr err_tm)
+                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm
                    ; fillCoercionHole hole (mkTcCoVarCo co_var) }}
 
   | otherwise   -- Do not set any evidence for Given/Derived
@@ -1072,7 +1095,9 @@ mkHoleError _ _ ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) })
   -- in-scope variables in the message, and note inaccessible exact matches
   = do { dflags   <- getDynFlags
        ; imp_info <- getImports
-       ; let suggs_msg = unknownNameSuggestions dflags rdr_env0
+       ; curr_mod <- getModule
+       ; hpt <- getHpt
+       ; let suggs_msg = unknownNameSuggestions dflags hpt curr_mod rdr_env0
                                                 (tcl_rdr lcl_env) imp_info rdr
        ; rdr_env     <- getGlobalRdrEnv
        ; splice_locs <- getTopLevelSpliceLocs
@@ -1152,7 +1177,7 @@ mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_hole = hole })
   where
     occ       = holeOcc hole
     hole_ty   = ctEvPred (ctEvidence ct)
-    hole_kind = typeKind hole_ty
+    hole_kind = tcTypeKind hole_ty
     tyvars    = tyCoVarsOfTypeList hole_ty
 
     hole_msg = case hole of
@@ -1167,8 +1192,8 @@ mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_hole = hole })
 
     pp_hole_type_with_kind
       | isLiftedTypeKind hole_kind
-        || isCoercionType hole_ty -- Don't print the kind of unlifted
-                                  -- equalities (#15039)
+        || isCoVarType hole_ty -- Don't print the kind of unlifted
+                               -- equalities (#15039)
       = pprType hole_ty
       | otherwise
       = pprType hole_ty <+> dcolon <+> pprKind hole_kind
@@ -1228,9 +1253,9 @@ givenConstraintsMsg :: ReportErrCtxt -> SDoc
 givenConstraintsMsg ctxt =
     let constraints :: [(Type, RealSrcSpan)]
         constraints =
-          do { Implic{ ic_given = given, ic_env = env } <- cec_encl ctxt
+          do { implic@Implic{ ic_given = given } <- cec_encl ctxt
              ; constraint <- given
-             ; return (varType constraint, tcl_loc env) }
+             ; return (varType constraint, tcl_loc (implicLclEnv implic)) }
 
         pprConstraint (constraint, loc) =
           ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))
@@ -1475,9 +1500,9 @@ mkEqErr1 ctxt ct   -- Wanted or derived;
                          || not (cty1 `pickyEqType` cty2)
                          -> hang (text "When matching" <+> sub_what)
                                2 (vcat [ ppr cty1 <+> dcolon <+>
-                                         ppr (typeKind cty1)
+                                         ppr (tcTypeKind cty1)
                                        , ppr cty2 <+> dcolon <+>
-                                         ppr (typeKind cty2) ])
+                                         ppr (tcTypeKind cty2) ])
                        _ -> text "When matching the kind of" <+> quotes (ppr cty1)
               msg2 = case sub_o of
                        TypeEqOrigin {}
@@ -1598,7 +1623,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
   , isUserSkolem ctxt tv1   -- ty2 won't be a meta-tyvar, or else the thing would
                             -- be oriented the other way round;
                             -- see TcCanonical.canEqTyVarTyVar
-    || isSigTyVar tv1 && not (isTyVarTy ty2)
+    || isTyVarTyVar tv1 && not (isTyVarTy ty2)
     || ctEqRel ct == ReprEq
      -- the cases below don't really apply to ReprEq (except occurs check)
   = mkErrorMsgFromCt ctxt ct $ mconcat
@@ -1625,7 +1650,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
              extra3 = relevant_bindings $
                       ppWhen (not (null interesting_tyvars)) $
                       hang (text "Type variable kinds:") 2 $
-                      vcat (map (tyvar_binding . tidyTyVarOcc (cec_tidy ctxt))
+                      vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))
                                 interesting_tyvars)
 
              tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
@@ -1661,7 +1686,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
 
   -- If the immediately-enclosing implication has 'tv' a skolem, and
   -- we know by now its an InferSkol kind of skolem, then presumably
-  -- it started life as a SigTv, else it'd have been unified, given
+  -- it started life as a TyVarTv, else it'd have been unified, given
   -- that there's no occurs-check or forall problem
   | (implic:_) <- cec_encl ctxt
   , Implic { ic_skols = skols } <- implic
@@ -1674,7 +1699,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
 
   -- Check for skolem escape
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
-  , Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
+  , Implic { ic_skols = skols, ic_info = skol_info } <- implic
   , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
   , not (null esc_skols)
   = do { let msg = important $ misMatchMsg ct oriented ty1 ty2
@@ -1692,17 +1717,17 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
                                            what <+> text "variables are")
                                <+> text "bound by"
                              , nest 2 $ ppr skol_info
-                             , nest 2 $ text "at" <+> ppr (tcl_loc env) ] ]
+                             , nest 2 $ text "at" <+>
+                               ppr (tcl_loc (implicLclEnv implic)) ] ]
        ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }
 
   -- Nastiest case: attempt to unify an untouchable variable
   -- So tv is a meta tyvar (or started that way before we
   -- generalised it).  So presumably it is an *untouchable*
-  -- meta tyvar or a SigTv, else it'd have been unified
+  -- meta tyvar or a TyVarTv, else it'd have been unified
   -- See Note [Error messages for untouchables]
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
-  , Implic { ic_env = env, ic_given = given
-           , ic_tclvl = lvl, ic_info = skol_info } <- implic
+  , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic
   = ASSERT2( not (isTouchableMetaTyVar lvl tv1)
            , ppr tv1 $$ ppr lvl )  -- See Note [Error messages for untouchables]
     do { let msg = important $ misMatchMsg ct oriented ty1 ty2
@@ -1711,7 +1736,8 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
                   sep [ quotes (ppr tv1) <+> text "is untouchable"
                       , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
                       , nest 2 $ text "bound by" <+> ppr skol_info
-                      , nest 2 $ text "at" <+> ppr (tcl_loc env) ]
+                      , nest 2 $ text "at" <+>
+                        ppr (tcl_loc (implicLclEnv implic)) ]
              tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2
              add_sig  = important $ suggestAddSig ctxt ty1 ty2
        ; mkErrorMsgFromCt ctxt ct $ mconcat
@@ -1724,7 +1750,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
         -- Not an occurs check, because F is a type function.
   where
     Pair _ k1 = tcCoercionKind co1
-    k2        = typeKind ty2
+    k2        = tcTypeKind ty2
 
     ty1 = mkTyVarTy tv1
     occ_check_expand       = occCheckForErrors dflags tv1 ty2
@@ -1740,9 +1766,8 @@ mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
 --        (b) warning about injectivity if both sides are the same
 --            type function application   F a ~ F b
 --            See Note [Non-injective type functions]
---        (c) warning about -fprint-explicit-kinds if that might be helpful
 mkEqInfoMsg ct ty1 ty2
-  = tyfun_msg $$ ambig_msg $$ invis_msg
+  = tyfun_msg $$ ambig_msg
   where
     mb_fun1 = isTyFun_maybe ty1
     mb_fun2 = isTyFun_maybe ty2
@@ -1751,19 +1776,6 @@ mkEqInfoMsg ct ty1 ty2
               = snd (mkAmbigMsg False ct)
               | otherwise = empty
 
-    -- better to check the exp/act types in the CtOrigin than the actual
-    -- mismatched types for suggestion about -fprint-explicit-kinds
-    (act_ty, exp_ty) = case ctOrigin ct of
-      TypeEqOrigin { uo_actual = act
-                   , uo_expected = exp } -> (act, exp)
-      _                                  -> (ty1, ty2)
-
-    invis_msg | Just vis <- tcEqTypeVis act_ty exp_ty
-              , not vis
-              = ppSuggestExplicitKinds
-              | otherwise
-              = empty
-
     tyfun_msg | Just tc1 <- mb_fun1
               , Just tc2 <- mb_fun2
               , tc1 == tc2
@@ -1800,7 +1812,8 @@ misMatchOrCND ctxt ct oriented ty1 ty2
     eq_pred = ctEvPred ev
     orig    = ctEvOrigin ev
     givens  = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)]
-              -- Keep only UserGivens that have some equalities
+              -- Keep only UserGivens that have some equalities.
+              -- See Note [Suppress redundant givens during error reporting]
 
 couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
 couldNotDeduce givens (wanteds, orig)
@@ -1814,11 +1827,49 @@ pp_givens givens
          (g:gs) ->      ppr_given (text "from the context:") g
                  : map (ppr_given (text "or from:")) gs
     where
-       ppr_given herald (Implic { ic_given = gs, ic_info = skol_info
-                                , ic_env = env })
-           = hang (herald <+> pprEvVarTheta gs)
+       ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info })
+           = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs))
+             -- See Note [Suppress redundant givens during error reporting]
+             -- for why we use mkMinimalBySCs above.
                 2 (sep [ text "bound by" <+> ppr skol_info
-                       , text "at" <+> ppr (tcl_loc env) ])
+                       , text "at" <+> ppr (tcl_loc (implicLclEnv implic)) ])
+
+{-
+Note [Suppress redundant givens during error reporting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When GHC is unable to solve a constraint and prints out an error message, it
+will print out what given constraints are in scope to provide some context to
+the programmer. But we shouldn't print out /every/ given, since some of them
+are not terribly helpful to diagnose type errors. Consider this example:
+
+  foo :: Int :~: Int -> a :~: b -> a :~: c
+  foo Refl Refl = Refl
+
+When reporting that GHC can't solve (a ~ c), there are two givens in scope:
+(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e.,
+redundant), so it's not terribly useful to report it in an error message.
+To accomplish this, we discard any Implications that do not bind any
+equalities by filtering the `givens` selected in `misMatchOrCND` (based on
+the `ic_no_eqs` field of the Implication).
+
+But this is not enough to avoid all redundant givens! Consider this example,
+from #15361:
+
+  goo :: forall (a :: Type) (b :: Type) (c :: Type).
+         a :~~: b -> a :~~: c
+  goo HRefl = HRefl
+
+Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope.
+The (* ~ *) part arises due the kinds of (:~~:) being unified. More
+importantly, (* ~ *) is redundant, so we'd like not to report it. However,
+the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its
+ic_no_eqs field), so the test above will keep it wholesale.
+
+To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b)
+part. This works because mkMinimalBySCs eliminates reflexive equalities in
+addition to superclasses (see Note [Remove redundant provided dicts]
+in TcPatSyn).
+-}
 
 extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
 -- Add on extra info about skolem constants
@@ -1868,17 +1919,16 @@ misMatchMsg ct oriented ty1 ty2
   -- These next two cases are when we're about to report, e.g., that
   -- 'LiftedRep doesn't match 'VoidRep. Much better just to say
   -- lifted vs. unlifted
-  | Just (tc1, []) <- splitTyConApp_maybe ty1
-  , tc1 `hasKey` liftedRepDataConKey
+  | isLiftedRuntimeRep ty1
   = lifted_vs_unlifted
 
-  | Just (tc2, []) <- splitTyConApp_maybe ty2
-  , tc2 `hasKey` liftedRepDataConKey
+  | isLiftedRuntimeRep ty2
   = lifted_vs_unlifted
 
   | otherwise  -- So now we have Nothing or (Just IsSwapped)
                -- For some reason we treat Nothing like IsSwapped
   = addArising orig $
+    pprWithExplicitKindsWhenMismatch ty1 ty2 (ctOrigin ct) $
     sep [ text herald1 <+> quotes (ppr ty1)
         , nest padding $
           text herald2 <+> quotes (ppr ty2)
@@ -1913,19 +1963,41 @@ misMatchMsg ct oriented ty1 ty2
       = addArising orig $
         text "Couldn't match a lifted type with an unlifted type"
 
+-- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a
+-- type mismatch occurs to due invisible kind arguments.
+--
+-- This function first checks to see if the 'CtOrigin' argument is a
+-- 'TypeEqOrigin', and if so, uses the expected/actual types from that to
+-- check for a kind mismatch (as these types typically have more surrounding
+-- types and are likelier to be able to glean information about whether a
+-- mismatch occurred in an invisible argument position or not). If the
+-- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types
+-- themselves.
+pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin
+                                 -> SDoc -> SDoc
+pprWithExplicitKindsWhenMismatch ty1 ty2 ct
+  = pprWithExplicitKindsWhen show_kinds
+  where
+    (act_ty, exp_ty) = case ct of
+      TypeEqOrigin { uo_actual = act
+                   , uo_expected = exp } -> (act, exp)
+      _                                  -> (ty1, ty2)
+    show_kinds = tcEqTypeVis act_ty exp_ty
+                 -- True when the visible bit of the types look the same,
+                 -- so we want to show the kinds in the displayed type
+
 mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool
                     -> (Bool, Maybe SwapFlag, SDoc)
 -- NotSwapped means (actual, expected), IsSwapped is the reverse
 -- First return val is whether or not to print a herald above this msg
-mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
-                                          , uo_expected = exp
-                                          , uo_thing = maybe_thing })
+mkExpectedActualMsg ty1 ty2 ct@(TypeEqOrigin { uo_actual = act
+                                             , uo_expected = exp
+                                             , uo_thing = maybe_thing })
                     m_level printExpanded
   | KindLevel <- level, occurs_check_error       = (True, Nothing, empty)
   | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2)
   | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3)
-  | isLiftedTypeKind exp && not (isConstraintKind exp)
-                                                 = (False, Nothing, msg4)
+  | tcIsLiftedTypeKind exp                       = (False, Nothing, msg4)
   | Just msg <- num_args_msg                     = (False, Nothing, msg $$ msg1)
   | KindLevel <- level, Just th <- maybe_thing   = (False, Nothing, msg5 th)
   | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty)
@@ -1954,7 +2026,8 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
         -> msg5 th
 
       _ | not (act `pickyEqType` exp)
-        -> vcat [ text "Expected" <+> sort <> colon <+> ppr exp
+        -> pprWithExplicitKindsWhenMismatch ty1 ty2 ct $
+           vcat [ text "Expected" <+> sort <> colon <+> ppr exp
                 , text "  Actual" <+> sort <> colon <+> ppr act
                 , if printExpanded then expandedTys else empty ]
 
@@ -1976,21 +2049,21 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
                        maybe_thing
                , quotes (pprWithTYPE act) ]
 
-    msg5 th = hang (text "Expected" <+> kind_desc <> comma)
+    msg5 th = pprWithExplicitKindsWhenMismatch ty1 ty2 ct $
+              hang (text "Expected" <+> kind_desc <> comma)
                  2 (text "but" <+> quotes th <+> text "has kind" <+>
                     quotes (ppr act))
       where
-        kind_desc | isConstraintKind exp = text "a constraint"
+        kind_desc | tcIsConstraintKind exp = text "a constraint"
 
                     -- TYPE t0
-                  | Just (tc, [arg]) <- tcSplitTyConApp_maybe exp
-                  , tc `hasKey` tYPETyConKey
-                  , tcIsTyVarTy arg      = sdocWithDynFlags $ \dflags ->
-                                           if gopt Opt_PrintExplicitRuntimeReps dflags
-                                           then text "kind" <+> quotes (ppr exp)
-                                           else text "a type"
+                  | Just arg <- kindRep_maybe exp
+                  , tcIsTyVarTy arg = sdocWithDynFlags $ \dflags ->
+                                      if gopt Opt_PrintExplicitRuntimeReps dflags
+                                      then text "kind" <+> quotes (ppr exp)
+                                      else text "a type"
 
-                  | otherwise            = text "kind" <+> quotes (ppr exp)
+                  | otherwise       = text "kind" <+> quotes (ppr exp)
 
     num_args_msg = case level of
       KindLevel
@@ -2126,10 +2199,11 @@ expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)
           (t1_2', t2_2') = go t1_2 t2_2
        in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')
 
-    go (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) =
+    go ty1@(FunTy _ t1_1 t1_2) ty2@(FunTy _ t2_1 t2_2) =
       let (t1_1', t2_1') = go t1_1 t2_1
           (t1_2', t2_2') = go t1_2 t2_2
-       in (mkFunTy t1_1' t1_2', mkFunTy t2_1' t2_2')
+       in ( ty1 { ft_arg = t1_1', ft_res = t1_2' }
+          , ty2 { ft_arg = t2_1', ft_res = t2_2' })
 
     go (ForAllTy b1 t1) (ForAllTy b2 t2) =
       -- NOTE: We may have a bug here, but we just can't reproduce it easily.
@@ -2424,7 +2498,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
         mb_patsyn_prov :: Maybe SDoc
         mb_patsyn_prov
           | not lead_with_ambig
-          , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig
+          , ProvCtxtOrigin PSB{ psb_def = (dL->L _ pat) } <- orig
           = Just (vcat [ text "In other words, a successful match on the pattern"
                        , nest 2 $ ppr pat
                        , text "does not provide the constraint" <+> pprParendType pred ])
@@ -2443,7 +2517,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
                , not (isTypeFamilyTyCon tc)
                = hang (text "GHC can't yet do polykinded")
                     2 (text "Typeable" <+>
-                       parens (ppr ty <+> dcolon <+> ppr (typeKind ty)))
+                       parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty)))
                | otherwise
                = empty
 
@@ -2496,21 +2570,22 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
 
     matching_givens = mapMaybe matchable useful_givens
 
-    matchable (Implic { ic_given = evvars, ic_info = skol_info, ic_env = env })
+    matchable implic@(Implic { ic_given = evvars, ic_info = skol_info })
       = case ev_vars_matching of
              [] -> Nothing
              _  -> Just $ hang (pprTheta ev_vars_matching)
                             2 (sep [ text "bound by" <+> ppr skol_info
-                                   , text "at" <+> ppr (tcl_loc env) ])
-        where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
-              ev_var_matches ty = case getClassPredTys_maybe ty of
-                 Just (clas', tys')
-                   | clas' == clas
-                   , Just _ <- tcMatchTys tys tys'
-                   -> True
-                   | otherwise
-                   -> any ev_var_matches (immSuperClasses clas' tys')
-                 Nothing -> False
+                                   , text "at" <+>
+                                     ppr (tcl_loc (implicLclEnv implic)) ])
+        where ev_vars_matching = [ pred
+                                 | ev_var <- evvars
+                                 , let pred = evVarPred ev_var
+                                 , any can_match (pred : transSuperClasses pred) ]
+              can_match pred
+                 = case getClassPredTys_maybe pred of
+                     Just (clas', tys') -> clas' == clas
+                                          && isJust (tcMatchTys tys tys')
+                     Nothing -> False
 
     -- Overlap error because of Safe Haskell (first
     -- match should be the most specific match)
@@ -2552,7 +2627,7 @@ ctxtFixes has_ambig_tvs pred implics
 
 discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]
 discardProvCtxtGivens orig givens  -- See Note [discardProvCtxtGivens]
-  | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig
+  | ProvCtxtOrigin (PSB {psb_id = (dL->L _ name)}) <- orig
   = filterOut (discard name) givens
   | otherwise
   = givens
@@ -2641,7 +2716,7 @@ the alleged "provided" constraints, Show a.
 
 So we suppress that Implication in discardProvCtxtGivens.  It's
 painfully ad-hoc but the truth is that adding it to the "required"
-constraints would work.  Suprressing it solves two problems.  First,
+constraints would work.  Suppressing it solves two problems.  First,
 we never tell the user that we could not deduce a "provided"
 constraint from the "required" context. Second, we never give a
 possible fix that suggests to add a "provided" constraint to the
@@ -2758,15 +2833,26 @@ Re-flattening is pretty easy, because we don't need to keep track of
 evidence.  We don't re-use the code in TcCanonical because that's in
 the TcS monad, and we are in TcM here.
 
-Note [Suggest -fprint-explicit-kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Kind arguments in error messages]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It can be terribly confusing to get an error message like (Trac #9171)
+
     Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
                 with actual type ‘GetParam Base (GetParam Base Int)’
+
 The reason may be that the kinds don't match up.  Typically you'll get
 more useful information, but not when it's as a result of ambiguity.
-This test suggests -fprint-explicit-kinds when all the ambiguous type
-variables are kind variables.
+
+To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag
+whenever any error message arises due to a kind mismatch. This means that
+the above error message would instead be displayed as:
+
+    Couldn't match expected type
+                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’
+                with actual type
+                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’
+
+Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.
 -}
 
 mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence
@@ -2786,10 +2872,8 @@ mkAmbigMsg prepend_msg ct
         | not (null ambig_tvs)
         = pp_ambig (text "type") ambig_tvs
 
-        | otherwise  -- All ambiguous kind variabes; suggest -fprint-explicit-kinds
-                     -- See Note [Suggest -fprint-explicit-kinds]
-        = vcat [ pp_ambig (text "kind") ambig_kvs
-               , ppSuggestExplicitKinds ]
+        | otherwise
+        = pp_ambig (text "kind") ambig_kvs
 
     pp_ambig what tkvs
       | prepend_msg -- "Ambiguous type variable 't0'"