Refactor the constraint solver pipelinewip/T23070

The big change is to put the entire type-equality solver into
GHC.Tc.Solver.Equality, rather than scattering it over Canonical
and Interact.  Other changes

* EqCt becomes its own data type, a bit like QCInst.  This is
  great because EqualCtList is then just [EqCt]

* New module GHC.Tc.Solver.Dict has come of the class-contraint
  solver.  In due course it will be all.  One step at a time.

This MR is intended to have zero change in behaviour: it is a
pure refactor.  It opens the way to subsequent tidying up, we
believe.

14 files changed, 4302 insertions, 4162 deletions

diff --git a/compiler/GHC/Data/Bag.hs b/compiler/GHC/Data/Bag.hs
index a79bc41e6f..5ace42ba13 100644
--- a/compiler/GHC/Data/Bag.hs
+++ b/compiler/GHC/Data/Bag.hs
@@ -12,7 +12,7 @@ module GHC.Data.Bag (
         Bag, -- abstract type
 
         emptyBag, unitBag, unionBags, unionManyBags,
-        mapBag,
+        mapBag, pprBag,
         elemBag, lengthBag,
         filterBag, partitionBag, partitionBagWith,
         concatBag, catBagMaybes, foldBag,
@@ -324,7 +324,10 @@ headMaybe (TwoBags b1 _) = headMaybe b1
 headMaybe (ListBag (v:|_)) = Just v
 
 instance (Outputable a) => Outputable (Bag a) where
-    ppr bag = braces (pprWithCommas ppr (bagToList bag))
+    ppr = pprBag
+
+pprBag :: Outputable a => Bag a -> SDoc
+pprBag bag = braces (pprWithCommas ppr (bagToList bag))
 
 instance Data a => Data (Bag a) where
   gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index bef422c9a2..187cdc9c8b 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -14,54 +14,46 @@ module GHC.Tc.Solver.Canonical(
 import GHC.Prelude
 
 import GHC.Tc.Types.Constraint
-import GHC.Core.Predicate
 import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.Unify
 import GHC.Tc.Utils.TcType
-import GHC.Core.Type
 import GHC.Tc.Solver.Rewrite
 import GHC.Tc.Solver.Monad
-import GHC.Tc.Solver.InertSet
+import GHC.Tc.Solver.Equality( solveNonCanonicalEquality, solveCanonicalEquality )
 import GHC.Tc.Types.Evidence
 import GHC.Tc.Types.EvTerm
+
+import GHC.Core.Type
+import GHC.Core.Predicate
 import GHC.Core.Class
-import GHC.Core.DataCon ( dataConName )
-import GHC.Core.TyCon
 import GHC.Core.Multiplicity
-import GHC.Core.TyCo.Rep   -- cleverly decomposes types, good for completeness checking
 import GHC.Core.Coercion
-import GHC.Core.Coercion.Axiom
 import GHC.Core.Reduction
 import GHC.Core.InstEnv ( Coherence(..) )
 import GHC.Core
+
+import GHC.Hs.Type( HsIPName(..) )
+
 import GHC.Types.Id( mkTemplateLocals )
-import GHC.Core.FamInstEnv ( FamInstEnvs )
-import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe )
 import GHC.Types.Var
 import GHC.Types.Var.Env( mkInScopeSet )
-import GHC.Types.Var.Set( delVarSetList, anyVarSet )
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Builtin.Types ( anyTypeOfKind )
+import GHC.Types.Var.Set( delVarSetList )
 import GHC.Types.Name.Set
-import GHC.Types.Name.Reader
-import GHC.Hs.Type( HsIPName(..) )
 import GHC.Types.Unique  ( hasKey )
+
 import GHC.Builtin.Names ( coercibleTyConKey )
 
-import GHC.Data.Pair
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
 import GHC.Utils.Misc
-import GHC.Data.Bag
 import GHC.Utils.Monad
-import GHC.Utils.Constants( debugIsOn )
-import Control.Monad
-import Data.Maybe ( isJust, isNothing )
-import Data.List  ( zip4 )
-import GHC.Types.Basic
+
 import GHC.Driver.Session ( givensFuel, wantedsFuel, qcsFuel )
+
+import GHC.Data.Bag
+
+import Data.Maybe ( isJust )
 import qualified Data.Semigroup as S
-import Data.Bifunctor ( bimap )
 
 {-
 ************************************************************************
@@ -100,6 +92,8 @@ canonicalize (CNonCanonical { cc_ev = ev })
   = {-# SCC "canNC" #-}
     canNC ev
 
+canonicalize (CEqCan can_eq_ct) = solveCanonicalEquality can_eq_ct
+
 canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))
   = canForAll ev pend_sc
 
@@ -118,20 +112,13 @@ canonicalize (CDictCan { cc_ev = ev, cc_class  = cls
   = {-# SCC "canClass" #-}
     canClass ev cls xis pend_sc
 
-canonicalize (CEqCan { cc_ev     = ev
-                     , cc_lhs    = lhs
-                     , cc_rhs    = rhs
-                     , cc_eq_rel = eq_rel })
-  = {-# SCC "canEqLeafTyVarEq" #-}
-    canEqNC ev eq_rel (canEqLHSType lhs) rhs
-
 canNC :: CtEvidence -> TcS (StopOrContinue Ct)
 canNC ev =
   case classifyPredType pred of
       ClassPred cls tys     -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
                                   canClassNC ev cls tys
       EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)
-                                  canEqNC    ev eq_rel ty1 ty2
+                                  solveNonCanonicalEquality    ev eq_rel ty1 ty2
       IrredPred {}          -> do traceTcS "canEvNC:irred" (ppr pred)
                                   canIrred ev
       ForAllPred tvs th p   -> do traceTcS "canEvNC:forall" (ppr pred)
@@ -980,2185 +967,7 @@ we just add it to TcS's local InstEnv of known instances,
 via addInertForall.  Then, if we look up (C x Int Bool), say,
 we'll find a match in the InstEnv.
 
-************************************************************************
-*                                                                      *
-*        Equalities
-*                                                                      *
-************************************************************************
-
-Note [Canonicalising equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In order to canonicalise an equality, we look at the structure of the
-two types at hand, looking for similarities. A difficulty is that the
-types may look dissimilar before rewriting but similar after rewriting.
-However, we don't just want to jump in and rewrite right away, because
-this might be wasted effort. So, after looking for similarities and failing,
-we rewrite and then try again. Of course, we don't want to loop, so we
-track whether or not we've already rewritten.
-
-It is conceivable to do a better job at tracking whether or not a type
-is rewritten, but this is left as future work. (Mar '15)
-
-Note [Decomposing FunTy]
-~~~~~~~~~~~~~~~~~~~~~~~~
-can_eq_nc' may attempt to decompose a FunTy that is un-zonked.  This
-means that we may very well have a FunTy containing a type of some
-unknown kind. For instance, we may have,
-
-    FunTy (a :: k) Int
-
-Where k is a unification variable. So the calls to splitRuntimeRep_maybe may
-fail (returning Nothing).  In that case we'll fall through, zonk, and try again.
-Zonking should fill the variable k, meaning that decomposition will succeed the
-second time around.
-
-Also note that we require the FunTyFlag to match.  This will stop
-us decomposing
-   (Int -> Bool)  ~  (Show a => blah)
-It's as if we treat (->) and (=>) as different type constructors, which
-indeed they are!
--}
-
-canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)
-canEqNC ev eq_rel ty1 ty2
-  = do { result <- zonk_eq_types ty1 ty2
-       ; case result of
-           Right ty              -> canEqReflexive ev eq_rel ty
-           Left (Pair ty1' ty2') -> can_eq_nc False ev' eq_rel ty1' ty1' ty2' ty2'
-             where
-               ev' | debugIsOn = setCtEvPredType ev $
-                                 mkPrimEqPredRole (eqRelRole eq_rel) ty1' ty2'
-                   | otherwise = ev
-                   -- ev': satisfy the precondition of can_eq_nc
-       }
-
-can_eq_nc
-   :: Bool            -- True => both types are rewritten
-   -> CtEvidence
-   -> EqRel
-   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp
-   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp
-   -> TcS (StopOrContinue Ct)
--- Precondition: in DEBUG mode, the `ctev_pred` of `ev` is (ps_ty1 ~# ps_ty2),
---               without zonking
--- This precondition is needed (only in DEBUG) to satisfy the assertions
---   in mkSelCo, called in canDecomposableTyConAppOK and canDecomposableFunTy
-
-can_eq_nc rewritten ev eq_rel ty1 ps_ty1 ty2 ps_ty2
-  = do { traceTcS "can_eq_nc" $
-         vcat [ ppr rewritten, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ]
-       ; rdr_env <- getGlobalRdrEnvTcS
-       ; fam_insts <- getFamInstEnvs
-       ; can_eq_nc' rewritten rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 }
-
-can_eq_nc'
-   :: Bool           -- True => both input types are rewritten
-   -> GlobalRdrEnv   -- needed to see which newtypes are in scope
-   -> FamInstEnvs    -- needed to unwrap data instances
-   -> CtEvidence
-   -> EqRel
-   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp
-   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp
-   -> TcS (StopOrContinue Ct)
-
--- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
-can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2
-  | tc1 == tc2
-  = canEqReflexive ev eq_rel ty1
-
--- Expand synonyms first; see Note [Type synonyms and canonicalization]
-can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
-  | Just ty1' <- coreView ty1 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2  ps_ty2
-  | Just ty2' <- coreView ty2 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1  ps_ty1 ty2' ps_ty2
-
--- need to check for reflexivity in the ReprEq case.
--- See Note [Eager reflexivity check]
--- Check only when rewritten because the zonk_eq_types check in canEqNC takes
--- care of the non-rewritten case.
-can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _
-  | ty1 `tcEqType` ty2
-  = canEqReflexive ev ReprEq ty1
-
--- When working with ReprEq, unwrap newtypes.
--- See Note [Unwrap newtypes first]
--- This must be above the TyVarTy case, in order to guarantee (TyEq:N)
-can_eq_nc' _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
-  | ReprEq <- eq_rel
-  , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1
-  = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2
-
-  | ReprEq <- eq_rel
-  , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2
-  = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1
-
--- Then, get rid of casts
-can_eq_nc' rewritten _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
-  | isNothing (canEqLHS_maybe ty2)  -- See (3) in Note [Equalities with incompatible kinds]
-  = canEqCast rewritten ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2
-can_eq_nc' rewritten _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
-  | isNothing (canEqLHS_maybe ty1)  -- See (3) in Note [Equalities with incompatible kinds]
-  = canEqCast rewritten ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1
-
-----------------------
--- Otherwise try to decompose
-----------------------
-
--- Literals
-can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
- | l1 == l2
-  = do { setEvBindIfWanted ev IsCoherent (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)
-       ; stopWith ev "Equal LitTy" }
-
--- Decompose FunTy: (s -> t) and (c => t)
--- NB: don't decompose (Int -> blah) ~ (Show a => blah)
-can_eq_nc' _rewritten _rdr_env _envs ev eq_rel
-           (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1
-           (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2
-  | af1 == af2  -- See Note [Decomposing FunTy]
-  = canDecomposableFunTy ev eq_rel af1 (am1,ty1a,ty1b) (am2,ty2a,ty2b)
-
--- Decompose type constructor applications
--- NB: we have expanded type synonyms already
-can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _
-  | Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1
-  , Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2
-   -- we want to catch e.g. Maybe Int ~ (Int -> Int) here for better
-   -- error messages rather than decomposing into AppTys;
-   -- hence no direct match on TyConApp
-  , not (isTypeFamilyTyCon tc1)
-  , not (isTypeFamilyTyCon tc2)
-  = canTyConApp ev eq_rel tc1 tys1 tc2 tys2
-
-can_eq_nc' _rewritten _rdr_env _envs ev eq_rel
-           s1@(ForAllTy (Bndr _ vis1) _) _
-           s2@(ForAllTy (Bndr _ vis2) _) _
-  | vis1 `eqForAllVis` vis2 -- Note [ForAllTy and type equality]
-  = can_eq_nc_forall ev eq_rel s1 s2
-
--- See Note [Canonicalising type applications] about why we require rewritten types
--- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families
--- NB: Only decompose AppTy for nominal equality.
---     See Note [Decomposing AppTy equalities]
-can_eq_nc' True _rdr_env _envs ev NomEq ty1 _ ty2 _
-  | Just (t1, s1) <- tcSplitAppTy_maybe ty1
-  , Just (t2, s2) <- tcSplitAppTy_maybe ty2
-  = can_eq_app ev t1 s1 t2 s2
-
--------------------
--- Can't decompose.
--------------------
-
--- No similarity in type structure detected. Rewrite and try again.
-can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
-  = -- Rewrite the two types and try again
-    do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1
-       ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2
-       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
-       ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
-
-----------------------------
--- Look for a canonical LHS. See Note [Canonical LHS].
--- Only rewritten types end up below here.
-----------------------------
-
--- NB: pattern match on True: we want only rewritten types sent to canEqLHS
--- This means we've rewritten any variables and reduced any type family redexes
--- See also Note [No top-level newtypes on RHS of representational equalities]
-can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
-  | Just can_eq_lhs1 <- canEqLHS_maybe ty1
-  = canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2
-
-  | Just can_eq_lhs2 <- canEqLHS_maybe ty2
-  = canEqCanLHS ev eq_rel IsSwapped can_eq_lhs2 ps_ty2 ty1 ps_ty1
-
-     -- If the type is TyConApp tc1 args1, then args1 really can't be less
-     -- than tyConArity tc1. It could be *more* than tyConArity, but then we
-     -- should have handled the case as an AppTy. That case only fires if
-     -- _both_ sides of the equality are AppTy-like... but if one side is
-     -- AppTy-like and the other isn't (and it also isn't a variable or
-     -- saturated type family application, both of which are handled by
-     -- can_eq_nc'), we're in a failure mode and can just fall through.
-
-----------------------------
--- Fall-through. Give up.
-----------------------------
-
--- We've rewritten and the types don't match. Give up.
-can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2
-  = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)
-       ; case eq_rel of -- See Note [Unsolved equalities]
-            ReprEq -> continueWith (mkIrredCt ReprEqReason ev)
-            NomEq  -> continueWith (mkIrredCt ShapeMismatchReason ev) }
-          -- No need to call canEqFailure/canEqHardFailure because they
-          -- rewrite, and the types involved here are already rewritten
-
-
-{- Note [Unsolved equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have an unsolved equality like
-  (a b ~R# Int)
-that is not necessarily insoluble!  Maybe 'a' will turn out to be a newtype.
-So we want to make it a potentially-soluble Irred not an insoluble one.
-Missing this point is what caused #15431
--}
-
----------------------------------
-can_eq_nc_forall :: CtEvidence -> EqRel
-                 -> Type -> Type    -- LHS and RHS
-                 -> TcS (StopOrContinue Ct)
--- (forall as. phi1) ~ (forall bs. phi2)
--- Check for length match of as, bs
--- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs]
--- But remember also to unify the kinds of as and bs
---  (this is the 'go' loop), and actually substitute phi2[as |> cos / bs]
--- Remember also that we might have forall z (a:z). blah
---  so we must proceed one binder at a time (#13879)
-
-can_eq_nc_forall ev eq_rel s1 s2
- | CtWanted { ctev_loc = loc, ctev_dest = orig_dest, ctev_rewriters = rewriters } <- ev
- = do { let free_tvs       = tyCoVarsOfTypes [s1,s2]
-            (bndrs1, phi1) = tcSplitForAllTyVarBinders s1
-            (bndrs2, phi2) = tcSplitForAllTyVarBinders s2
-      ; if not (equalLength bndrs1 bndrs2)
-        then do { traceTcS "Forall failure" $
-                     vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2
-                          , ppr (binderFlags bndrs1)
-                          , ppr (binderFlags bndrs2) ]
-                ; canEqHardFailure ev s1 s2 }
-        else
-   do { traceTcS "Creating implication for polytype equality" $ ppr ev
-      ; let empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs
-      ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1)
-      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $
-                              binderVars bndrs1
-
-      ; let phi1' = substTy subst1 phi1
-
-            -- Unify the kinds, extend the substitution
-            go :: [TcTyVar] -> Subst -> [TyVarBinder]
-               -> TcS (TcCoercion, Cts)
-            go (skol_tv:skol_tvs) subst (bndr2:bndrs2)
-              = do { let tv2 = binderVar bndr2
-                   ; (kind_co, wanteds1) <- unify loc rewriters Nominal (tyVarKind skol_tv)
-                                                  (substTy subst (tyVarKind tv2))
-                   ; let subst' = extendTvSubstAndInScope subst tv2
-                                       (mkCastTy (mkTyVarTy skol_tv) kind_co)
-                         -- skol_tv is already in the in-scope set, but the
-                         -- free vars of kind_co are not; hence "...AndInScope"
-                   ; (co, wanteds2) <- go skol_tvs subst' bndrs2
-                   ; return ( mkForAllCo skol_tv kind_co co
-                            , wanteds1 `unionBags` wanteds2 ) }
-
-            -- Done: unify phi1 ~ phi2
-            go [] subst bndrs2
-              = assert (null bndrs2) $
-                unify loc rewriters (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)
-
-            go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) []
-
-            empty_subst2 = mkEmptySubst (getSubstInScope subst1)
-
-      ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $
-                                    go skol_tvs empty_subst2 bndrs2
-      ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds
-
-      ; setWantedEq orig_dest all_co
-      ; stopWith ev "Deferred polytype equality" } }
-
- | otherwise
- = do { traceTcS "Omitting decomposition of given polytype equality" $
-        pprEq s1 s2    -- See Note [Do not decompose Given polytype equalities]
-      ; stopWith ev "Discard given polytype equality" }
-
- where
-    unify :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)
-    -- This version returns the wanted constraint rather
-    -- than putting it in the work list
-    unify loc rewriters role ty1 ty2
-      | ty1 `tcEqType` ty2
-      = return (mkReflCo role ty1, emptyBag)
-      | otherwise
-      = do { (wanted, co) <- newWantedEq loc rewriters role ty1 ty2
-           ; return (co, unitBag (mkNonCanonical wanted)) }
-
----------------------------------
--- | Compare types for equality, while zonking as necessary. Gives up
--- as soon as it finds that two types are not equal.
--- This is quite handy when some unification has made two
--- types in an inert Wanted to be equal. We can discover the equality without
--- rewriting, which is sometimes very expensive (in the case of type functions).
--- In particular, this function makes a ~20% improvement in test case
--- perf/compiler/T5030.
---
--- Returns either the (partially zonked) types in the case of
--- inequality, or the one type in the case of equality. canEqReflexive is
--- a good next step in the 'Right' case. Returning 'Left' is always safe.
---
--- NB: This does *not* look through type synonyms. In fact, it treats type
--- synonyms as rigid constructors. In the future, it might be convenient
--- to look at only those arguments of type synonyms that actually appear
--- in the synonym RHS. But we're not there yet.
-zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType)
-zonk_eq_types = go
-  where
-    go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2
-    go (TyVarTy tv1) ty2           = tyvar NotSwapped tv1 ty2
-    go ty1 (TyVarTy tv2)           = tyvar IsSwapped  tv2 ty1
-
-    -- We handle FunTys explicitly here despite the fact that they could also be
-    -- treated as an application. Why? Well, for one it's cheaper to just look
-    -- at two types (the argument and result types) than four (the argument,
-    -- result, and their RuntimeReps). Also, we haven't completely zonked yet,
-    -- so we may run into an unzonked type variable while trying to compute the
-    -- RuntimeReps of the argument and result types. This can be observed in
-    -- testcase tc269.
-    go (FunTy af1 w1 arg1 res1) (FunTy af2 w2 arg2 res2)
-      | af1 == af2
-      , eqType w1 w2
-      = do { res_a <- go arg1 arg2
-           ; res_b <- go res1 res2
-           ; return $ combine_rev (FunTy af1 w1) res_b res_a }
-
-    go ty1@(FunTy {}) ty2 = bale_out ty1 ty2
-    go ty1 ty2@(FunTy {}) = bale_out ty1 ty2
-
-    go ty1 ty2
-      | Just (tc1, tys1) <- splitTyConAppNoView_maybe ty1
-      , Just (tc2, tys2) <- splitTyConAppNoView_maybe ty2
-      = if tc1 == tc2 && tys1 `equalLength` tys2
-          -- Crucial to check for equal-length args, because
-          -- we cannot assume that the two args to 'go' have
-          -- the same kind.  E.g go (Proxy *      (Maybe Int))
-          --                        (Proxy (*->*) Maybe)
-          -- We'll call (go (Maybe Int) Maybe)
-          -- See #13083
-        then tycon tc1 tys1 tys2
-        else bale_out ty1 ty2
-
-    go ty1 ty2
-      | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1
-      , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2
-      = do { res_a <- go ty1a ty2a
-           ; res_b <- go ty1b ty2b
-           ; return $ combine_rev mkAppTy res_b res_a }
-
-    go ty1@(LitTy lit1) (LitTy lit2)
-      | lit1 == lit2
-      = return (Right ty1)
-
-    go ty1 ty2 = bale_out ty1 ty2
-      -- We don't handle more complex forms here
-
-    bale_out ty1 ty2 = return $ Left (Pair ty1 ty2)
-
-    tyvar :: SwapFlag -> TcTyVar -> TcType
-          -> TcS (Either (Pair TcType) TcType)
-      -- Try to do as little as possible, as anything we do here is redundant
-      -- with rewriting. In particular, no need to zonk kinds. That's why
-      -- we don't use the already-defined zonking functions
-    tyvar swapped tv ty
-      = case tcTyVarDetails tv of
-          MetaTv { mtv_ref = ref }
-            -> do { cts <- readTcRef ref
-                  ; case cts of
-                      Flexi        -> give_up
-                      Indirect ty' -> do { trace_indirect tv ty'
-                                         ; unSwap swapped go ty' ty } }
-          _ -> give_up
-      where
-        give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty
-
-    tyvar_tyvar tv1 tv2
-      | tv1 == tv2 = return (Right (mkTyVarTy tv1))
-      | otherwise  = do { (ty1', progress1) <- quick_zonk tv1
-                        ; (ty2', progress2) <- quick_zonk tv2
-                        ; if progress1 || progress2
-                          then go ty1' ty2'
-                          else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) }
-
-    trace_indirect tv ty
-       = traceTcS "Following filled tyvar (zonk_eq_types)"
-                  (ppr tv <+> equals <+> ppr ty)
-
-    quick_zonk tv = case tcTyVarDetails tv of
-      MetaTv { mtv_ref = ref }
-        -> do { cts <- readTcRef ref
-              ; case cts of
-                  Flexi        -> return (TyVarTy tv, False)
-                  Indirect ty' -> do { trace_indirect tv ty'
-                                     ; return (ty', True) } }
-      _ -> return (TyVarTy tv, False)
-
-      -- This happens for type families, too. But recall that failure
-      -- here just means to try harder, so it's OK if the type function
-      -- isn't injective.
-    tycon :: TyCon -> [TcType] -> [TcType]
-          -> TcS (Either (Pair TcType) TcType)
-    tycon tc tys1 tys2
-      = do { results <- zipWithM go tys1 tys2
-           ; return $ case combine_results results of
-               Left tys  -> Left (mkTyConApp tc <$> tys)
-               Right tys -> Right (mkTyConApp tc tys) }
-
-    combine_results :: [Either (Pair TcType) TcType]
-                    -> Either (Pair [TcType]) [TcType]
-    combine_results = bimap (fmap reverse) reverse .
-                      foldl' (combine_rev (:)) (Right [])
-
-      -- combine (in reverse) a new result onto an already-combined result
-    combine_rev :: (a -> b -> c)
-                -> Either (Pair b) b
-                -> Either (Pair a) a
-                -> Either (Pair c) c
-    combine_rev f (Left list) (Left elt) = Left (f <$> elt     <*> list)
-    combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list)
-    combine_rev f (Right tys) (Left elt) = Left (f <$> elt     <*> pure tys)
-    combine_rev f (Right tys) (Right ty) = Right (f ty tys)
-
-{- Note [Unwrap newtypes first]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also Note [Decomposing newtype equalities]
-
-Consider
-  newtype N m a = MkN (m a)
-N will get a conservative, Nominal role for its second parameter 'a',
-because it appears as an argument to the unknown 'm'. Now consider
-  [W] N Maybe a  ~R#  N Maybe b
-
-If we /decompose/, we'll get
-  [W] a ~N# b
-
-But if instead we /unwrap/ we'll get
-  [W] Maybe a ~R# Maybe b
-which in turn gives us
-  [W] a ~R# b
-which is easier to satisfy.
-
-Conclusion: we must unwrap newtypes before decomposing them. This happens
-in `can_eq_newtype_nc`
-
-We did flirt with making the /rewriter/ expand newtypes, rather than
-doing it in `can_eq_newtype_nc`.   But with recursive newtypes we want
-to be super-careful about expanding!
-
-   newtype A = MkA [A]   -- Recursive!
-
-   f :: A -> [A]
-   f = coerce
-
-We have [W] A ~R# [A].  If we rewrite [A], it'll expand to
-   [[[[[...]]]]]
-and blow the reduction stack.  See Note [Newtypes can blow the stack]
-in GHC.Tc.Solver.Rewrite.  But if we expand only the /top level/ of
-both sides, we get
-   [W] [A] ~R# [A]
-which we can, just, solve by reflexivity.
-
-So we simply unwrap, on-demand, at top level, in `can_eq_newtype_nc`.
-
-This is all very delicate. There is a real risk of a loop in the type checker
-with recursive newtypes -- but I think we're doomed to do *something*
-delicate, as we're really trying to solve for equirecursive type
-equality. Bottom line for users: recursive newtypes do not play well with type
-inference for representational equality.  See also Section 5.3.1 and 5.3.4 of
-"Safe Zero-cost Coercions for Haskell" (JFP 2016).
-
-See also Note [Decomposing newtype equalities].
-
---- Historical side note ---
-
-We flirted with doing /both/ unwrap-at-top-level /and/ rewrite-deeply;
-see #22519.  But that didn't work: see discussion in #22924. Specifically
-we got a loop with a minor variation:
-   f2 :: a -> [A]
-   f2 = coerce
-
-Note [Eager reflexivity check]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-
-  newtype X = MkX (Int -> X)
-
-and
-
-  [W] X ~R X
-
-Naively, we would start unwrapping X and end up in a loop. Instead,
-we do this eager reflexivity check. This is necessary only for representational
-equality because the rewriter technology deals with the similar case
-(recursive type families) for nominal equality.
-
-Note that this check does not catch all cases, but it will catch the cases
-we're most worried about, types like X above that are actually inhabited.
-
-Here's another place where this reflexivity check is key:
-Consider trying to prove (f a) ~R (f a). The AppTys in there can't
-be decomposed, because representational equality isn't congruent with respect
-to AppTy. So, when canonicalising the equality above, we get stuck and
-would normally produce a CIrredCan. However, we really do want to
-be able to solve (f a) ~R (f a). So, in the representational case only,
-we do a reflexivity check.
-
-(This would be sound in the nominal case, but unnecessary, and I [Richard
-E.] am worried that it would slow down the common case.)
-
- Note [Newtypes can blow the stack]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-
-  newtype X = MkX (Int -> X)
-  newtype Y = MkY (Int -> Y)
-
-and now wish to prove
-
-  [W] X ~R Y
-
-This Wanted will loop, expanding out the newtypes ever deeper looking
-for a solid match or a solid discrepancy. Indeed, there is something
-appropriate to this looping, because X and Y *do* have the same representation,
-in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized
-coercion will ever witness it. This loop won't actually cause GHC to hang,
-though, because we check our depth in `can_eq_newtype_nc`.
--}
-
-------------------------
--- | We're able to unwrap a newtype. Update the bits accordingly.
-can_eq_newtype_nc :: CtEvidence           -- ^ :: ty1 ~ ty2
-                  -> SwapFlag
-                  -> TcType                                    -- ^ ty1
-                  -> ((Bag GlobalRdrElt, TcCoercion), TcType)  -- ^ :: ty1 ~ ty1'
-                  -> TcType               -- ^ ty2
-                  -> TcType               -- ^ ty2, with type synonyms
-                  -> TcS (StopOrContinue Ct)
-can_eq_newtype_nc ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2
-  = do { traceTcS "can_eq_newtype_nc" $
-         vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ]
-
-         -- Check for blowing our stack, and increase the depth
-         -- See Note [Newtypes can blow the stack]
-       ; let loc = ctEvLoc ev
-             ev' = ev `setCtEvLoc` bumpCtLocDepth loc
-       ; checkReductionDepth loc ty1
-
-         -- Next, we record uses of newtype constructors, since coercing
-         -- through newtypes is tantamount to using their constructors.
-       ; recordUsedGREs gres
-
-       ; let redn1 = mkReduction co1 ty1'
-
-       ; new_ev <- rewriteEqEvidence emptyRewriterSet ev' swapped
-                     redn1
-                     (mkReflRedn Representational ps_ty2)
-       ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
-
----------
--- ^ Decompose a type application.
--- All input types must be rewritten. See Note [Canonicalising type applications]
--- Nominal equality only!
-can_eq_app :: CtEvidence       -- :: s1 t1 ~N s2 t2
-           -> Xi -> Xi         -- s1 t1
-           -> Xi -> Xi         -- s2 t2
-           -> TcS (StopOrContinue Ct)
-
--- AppTys only decompose for nominal equality, so this case just leads
--- to an irreducible constraint; see typecheck/should_compile/T10494
--- See Note [Decomposing AppTy equalities]
-can_eq_app ev s1 t1 s2 t2
-  | CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } <- ev
-  = do { co_s <- unifyWanted rewriters loc Nominal s1 s2
-       ; let arg_loc
-               | isNextArgVisible s1 = loc
-               | otherwise           = updateCtLocOrigin loc toInvisibleOrigin
-       ; co_t <- unifyWanted rewriters arg_loc Nominal t1 t2
-       ; let co = mkAppCo co_s co_t
-       ; setWantedEq dest co
-       ; stopWith ev "Decomposed [W] AppTy" }
-
-    -- If there is a ForAll/(->) mismatch, the use of the Left coercion
-    -- below is ill-typed, potentially leading to a panic in splitTyConApp
-    -- Test case: typecheck/should_run/Typeable1
-    -- We could also include this mismatch check above (for W and D), but it's slow
-    -- and we'll get a better error message not doing it
-  | s1k `mismatches` s2k
-  = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2)
-
-  | CtGiven { ctev_evar = evar } <- ev
-  = do { let co   = mkCoVarCo evar
-             co_s = mkLRCo CLeft  co
-             co_t = mkLRCo CRight co
-       ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2
-                                     , evCoercion co_s )
-       ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2
-                                     , evCoercion co_t )
-       ; emitWorkNC [evar_t]
-       ; canEqNC evar_s NomEq s1 s2 }
-
-  where
-    loc = ctEvLoc ev
-
-    s1k = typeKind s1
-    s2k = typeKind s2
-
-    k1 `mismatches` k2
-      =  isForAllTy k1 && not (isForAllTy k2)
-      || not (isForAllTy k1) && isForAllTy k2
-
------------------------
--- | Break apart an equality over a casted type
--- looking like   (ty1 |> co1) ~ ty2   (modulo a swap-flag)
-canEqCast :: Bool         -- are both types rewritten?
-          -> CtEvidence
-          -> EqRel
-          -> SwapFlag
-          -> TcType -> Coercion   -- LHS (res. RHS), ty1 |> co1
-          -> TcType -> TcType     -- RHS (res. LHS), ty2 both normal and pretty
-          -> TcS (StopOrContinue Ct)
-canEqCast rewritten ev eq_rel swapped ty1 co1 ty2 ps_ty2
-  = do { traceTcS "Decomposing cast" (vcat [ ppr ev
-                                           , ppr ty1 <+> text "|>" <+> ppr co1
-                                           , ppr ps_ty2 ])
-       ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
-                      (mkGReflLeftRedn role ty1 co1)
-                      (mkReflRedn role ps_ty2)
-       ; can_eq_nc rewritten new_ev eq_rel ty1 ty1 ty2 ps_ty2 }
-  where
-    role = eqRelRole eq_rel
-
-------------------------
-canTyConApp :: CtEvidence -> EqRel
-            -> TyCon -> [TcType]
-            -> TyCon -> [TcType]
-            -> TcS (StopOrContinue Ct)
--- See Note [Decomposing TyConApp equalities]
--- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
--- Neither tc1 nor tc2 is a saturated funTyCon, nor a type family
--- But they can be data families.
-canTyConApp ev eq_rel tc1 tys1 tc2 tys2
-  | tc1 == tc2
-  , tys1 `equalLength` tys2
-  = do { inerts <- getTcSInerts
-       ; if can_decompose inerts
-         then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2
-         else canEqFailure ev eq_rel ty1 ty2 }
-
-  -- See Note [Skolem abstract data] in GHC.Core.Tycon
-  | tyConSkolem tc1 || tyConSkolem tc2
-  = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)
-       ; continueWith (mkIrredCt AbstractTyConReason ev) }
-
-  -- Fail straight away for better error messages
-  -- See Note [Use canEqFailure in canDecomposableTyConApp]
-  | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational &&
-                             isGenerativeTyCon tc2 Representational)
-  = canEqFailure ev eq_rel ty1 ty2
-
-  | otherwise
-  = canEqHardFailure ev ty1 ty2
-  where
-    -- Reconstruct the types for error messages. This would do
-    -- the wrong thing (from a pretty printing point of view)
-    -- for functions, because we've lost the FunTyFlag; but
-    -- in fact we never call canTyConApp on a saturated FunTyCon
-    ty1 = mkTyConApp tc1 tys1
-    ty2 = mkTyConApp tc2 tys2
-
-     -- See Note [Decomposing TyConApp equalities]
-     -- and Note [Decomposing newtype equalities]
-    can_decompose inerts
-      =  isInjectiveTyCon tc1 (eqRelRole eq_rel)
-      || (assert (eq_rel == ReprEq) $
-          -- assert: isInjectiveTyCon is always True for Nominal except
-          --   for type synonyms/families, neither of which happen here
-          -- Moreover isInjectiveTyCon is True for Representational
-          --   for algebraic data types.  So we are down to newtypes
-          --   and data families.
-          ctEvFlavour ev == Wanted && noGivenNewtypeReprEqs tc1 inerts)
-             -- See Note [Decomposing newtype equalities] (EX2)
-
-{-
-Note [Use canEqFailure in canDecomposableTyConApp]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must use canEqFailure, not canEqHardFailure here, because there is
-the possibility of success if working with a representational equality.
-Here is one case:
-
-  type family TF a where TF Char = Bool
-  data family DF a
-  newtype instance DF Bool = MkDF Int
-
-Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet
-know `a`. This is *not* a hard failure, because we might soon learn
-that `a` is, in fact, Char, and then the equality succeeds.
-
-Here is another case:
-
-  [G] Age ~R Int
-
-where Age's constructor is not in scope. We don't want to report
-an "inaccessible code" error in the context of this Given!
-
-For example, see typecheck/should_compile/T10493, repeated here:
-
-  import Data.Ord (Down)  -- no constructor
-
-  foo :: Coercible (Down Int) Int => Down Int -> Int
-  foo = coerce
-
-That should compile, but only because we use canEqFailure and not
-canEqHardFailure.
-
-Note [Fast path when decomposing TyConApps]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we see (T s1 t1 ~ T s2 t2), then we can just decompose to
-  (s1 ~ s2, t1 ~ t2)
-and push those back into the work list.  But if
-  s1 = K k1    s2 = K k2
-then we will just decompose s1~s2, and it might be better to
-do so on the spot.  An important special case is where s1=s2,
-and we get just Refl.
-
-So canDecomposableTyConAppOK uses unifyWanted etc to short-cut that work.
-See also Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
-
-Note [Decomposing TyConApp equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-        [G/W] T ty1 ~r T ty2
-Can we decompose it, and replace it by
-        [G/W] ty1 ~r' ty2
-and if so what role is r'?  (In this Note, all the "~" are primitive
-equalities "~#", but I have dropped the noisy "#" symbols.)  Lots of
-background in the paper "Safe zero-cost coercions for Haskell".
-
-This Note covers the topic for
-  * Datatypes
-  * Newtypes
-  * Data families
-For the rest:
-  * Type synonyms: are always expanded
-  * Type families: see Note [Decomposing type family applications]
-  * AppTy:         see Note [Decomposing AppTy equalities].
-
----- Roles of the decomposed constraints ----
-For a start, the role r' will always be defined like this:
-  * If r=N then r' = N
-  * If r=R then r' = role of T's first argument
-
-For example:
-   data TR a = MkTR a       -- Role of T's first arg is Representational
-   data TN a = MkTN (F a)   -- Role of T's first arg is Nominal
-
-The function tyConRolesX :: Role -> TyCon -> [Role] gets the argument
-role r' for a TyCon T at role r.  E.g.
-   tyConRolesX Nominal          TR = [Nominal]
-   tyConRolesX Representational TR = [Representational]
-
----- Soundness and completeness ----
-For Givens, for /soundness/ of decomposition we need, forall ty1,ty2:
-    T ty1 ~r T ty2   ===>    ty1 ~r' ty2
-Here "===>" means "implies".  That is, given evidence for (co1 : T ty1 ~r T co2)
-we can produce evidence for (co2 : ty1 ~r' ty2).  But in the solver we
-/replace/ co1 with co2 in the inert set, and we don't want to lose any proofs
-thereby. So for /completeness/ of decomposition we also need the reverse:
-    ty1 ~r' ty2   ===>    T ty1 ~r T ty2
-
-For Wanteds, for /soundness/ of decomposition we need:
-    ty1 ~r' ty2   ===>    T ty1 ~r T ty2
-because if we do decompose we'll get evidence (co2 : ty1 ~r' ty2) and
-from that we want to derive evidence (T co2 : T ty1 ~r T ty2).
-For /completeness/ of decomposition we need the reverse implication too,
-else we may decompose to a new proof obligation that is stronger than
-the one we started with.  See Note [Decomposing newtype equalities].
-
----- Injectivity ----
-When do these bi-implications hold? In one direction it is easy.
-We /always/ have
-    ty1 ~r'  ty2   ===>    T ty1 ~r T ty2
-This is the CO_TYCONAPP rule of the paper (Fig 5); see also the
-TyConAppCo case of GHC.Core.Lint.lintCoercion.
-
-In the other direction, we have
-    T ty1 ~r T ty2   ==>   ty1 ~r' ty2  if T is /injective at role r/
-This is the very /definition/ of injectivity: injectivity means result
-is the same => arguments are the same, modulo the role shift.
-See comments on GHC.Core.TyCon.isInjectiveTyCon.  This is also
-the CO_NTH rule in Fig 5 of the paper, except in the paper only
-newtypes are non-injective at representation role, so the rule says "H
-is not a newtype".
-
-Injectivity is a bit subtle:
-                 Nominal   Representational
-   Datatype        YES        YES
-   Newtype         YES        NO{1}
-   Data family     YES        NO{2}
-
-{1} Consider newtype N a = MkN (F a)   -- Arg has Nominal role
-    Is it true that (N t1) ~R (N t2)   ==>   t1 ~N t2  ?
-    No, absolutely not.  E.g.
-       type instance F Int = Int; type instance F Bool = Char
-       Then (N Int) ~R (N Bool), by unwrapping, but we don't want Int~Char!
-
-    See Note [Decomposing newtype equalities]
-
-{2} We must treat data families precisely like newtypes, because of the
-    possibility of newtype instances. See also
-    Note [Decomposing newtype equalities]. See #10534 and
-    test case typecheck/should_fail/T10534.
-
----- Takeaway summary -----
-For sound and complete decomposition, we simply need injectivity;
-that is for isInjectiveTyCon to be true:
-
-* At Nominal role, isInjectiveTyCon is True for all the TyCons we are
-  considering in this Note: datatypes, newtypes, and data families.
-
-* For Givens, injectivity is necessary for soundness; completeness has no
-  side conditions.
-
-* For Wanteds, soundness has no side conditions; but injectivity is needed
-  for completeness. See Note [Decomposing newtype equalities]
-
-This is implemented in `can_decompose` in `canTyConApp`; it looks at
-injectivity, just as specified above.
-
-
-Note [Decomposing type family applications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Supose we have
-   [G/W]  (F ty1) ~r  (F ty2)
-This is handled by the TyFamLHS/TyFamLHS case of canEqCanLHS2.
-
-We never decompose to
-   [G/W]  ty1 ~r' ty2
-
-Instead
-
-* For Givens we do nothing. Injective type families have no corresponding
-  evidence of their injectivity, so we cannot decompose an
-  injective-type-family Given.
-
-* For Wanteds, for the Nominal role only, we emit new Wanteds rather like
-  functional dependencies, for each injective argument position.
-
-  E.g type family F a b   -- injective in first arg, but not second
-      [W] (F s1 t1) ~N (F s2 t2)
-  Emit new Wanteds
-      [W] s1 ~N s2
-  But retain the existing, unsolved constraint.
-
-Note [Decomposing newtype equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This Note also applies to data families, which we treat like
-newtype in case of 'newtype instance'.
-
-As Note [Decomposing TyConApp equalities] describes, if N is injective
-at role r, we can do this decomposition?
-   [G/W] (N ty1) ~r (N ty2)    to     [G/W]  ty1 ~r' ty2
-
-For a Given with r=R, the answer is a solid NO: newtypes are not injective at
-representational role, and we must not decompose, or we lose soundness.
-Example is wrinkle {1} in Note [Decomposing TyConApp equalities].
-
-For a Wanted with r=R, since newtypes are not injective at representational
-role, decomposition is sound, but we may lose completeness.  Nevertheless,
-if the newtype is abstract (so can't be unwrapped) we can only solve
-the equality by (a) using a Given or (b) decomposition.  If (a) is impossible
-(e.g. no Givens) then (b) is safe albeit potentially incomplete.
-
-There are two ways in which decomposing (N ty1) ~r (N ty2) could be incomplete:
-
-* Incompleteness example (EX1): unwrap first
-      newtype Nt a = MkNt (Id a)
-      type family Id a where Id a = a
-
-      [W] Nt Int ~R Nt Age
-
-  Because of its use of a type family, Nt's parameter will get inferred to
-  have a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age,
-  which is unsatisfiable. Unwrapping, though, leads to a solution.
-
-  Conclusion: always unwrap newtypes before attempting to decompose
-  them.  This is done in can_eq_nc'.  Of course, we can't unwrap if the data
-  constructor isn't in scope.  See Note [Unwrap newtypes first].
-
-* Incompleteness example (EX2): available Givens
-      newtype Nt a = Mk Bool         -- NB: a is not used in the RHS,
-      type role Nt representational  -- but the user gives it an R role anyway
-
-      [G] Nt t1 ~R Nt t2
-      [W] Nt alpha ~R Nt beta
-
-  We *don't* want to decompose to [W] alpha ~R beta, because it's possible
-  that alpha and beta aren't representationally equal.  And if we figure
-  out (elsewhere) that alpha:=t1 and beta:=t2, we can solve the Wanted
-  from the Given.  This is somewhat similar to the question of overlapping
-  Givens for class constraints: see Note [Instance and Given overlap] in
-  GHC.Tc.Solver.Interact.
-
-  Conclusion: don't decompose [W] N s ~R N t, if there are any Given
-  equalities that could later solve it.
-
-  But what precisely does it mean to say "any Given equalities that could
-  later solve it"?
-
-  In #22924 we had
-     [G] f a ~R# a     [W] Const (f a) a ~R# Const a a
-  where Const is an abstract newtype.  If we decomposed the newtype, we
-  could solve.  Not-decomposing on the grounds that (f a ~R# a) might turn
-  into (Const (f a) a ~R# Const a a) seems a bit silly.
-
-  In #22331 we had
-     [G] N a ~R# N b   [W] N b ~R# N a
-  (where N is abstract so we can't unwrap). Here we really /don't/ want to
-  decompose, because the /only/ way to solve the Wanted is from that Given
-  (with a Sym).
-
-  In #22519 we had
-     [G] a <= b     [W] IO Age ~R# IO Int
-
-  (where IO is abstract so we can't unwrap, and newtype Age = Int; and (<=)
-  is a type-level comparison on Nats).  Here we /must/ decompose, despite the
-  existence of an Irred Given, or we will simply be stuck.  (Side note: We
-  flirted with deep-rewriting of newtypes (see discussion on #22519 and
-  !9623) but that turned out not to solve #22924, and also makes type
-  inference loop more often on recursive newtypes.)
-
-  The currently-implemented compromise is this:
-
-    we decompose [W] N s ~R# N t unless there is a [G] N s' ~ N t'
-
-  that is, a Given Irred equality with both sides headed with N.
-  See the call to noGivenNewtypeReprEqs in canTyConApp.
-
-  This is not perfect.  In principle a Given like [G] (a b) ~ (c d), or
-  even just [G] c, could later turn into N s ~ N t.  But since the free
-  vars of a Given are skolems, or at least untouchable unification
-  variables, this is extremely unlikely to happen.
-
-  Another worry: there could, just, be a CDictCan with some
-  un-expanded equality superclasses; but only in some very obscure
-  recursive-superclass situations.
-
-   Yet another approach (!) is desribed in
-   Note [Decomposing newtypes a bit more aggressively].
-
-Remember: decomposing Wanteds is always /sound/. This Note is
-only about /completeness/.
-
-Note [Decomposing newtypes a bit more aggressively]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-IMPORTANT: the ideas in this Note are *not* implemented. Instead, the
-current approach is detailed in Note [Decomposing newtype equalities]
-and Note [Unwrap newtypes first].
-For more details about the ideas in this Note see
-  * GHC propoosal: https://github.com/ghc-proposals/ghc-proposals/pull/549
-  * issue #22441
-  * discussion on !9282.
-
-Consider [G] c, [W] (IO Int) ~R (IO Age)
-where IO is abstract, and
-   newtype Age = MkAge Int   -- Not abstract
-With the above rules, if there any Given Irreds,
-the Wanted is insoluble because we can't decompose it.  But in fact,
-if we look at the defn of IO, roughly,
-    newtype IO a = State# -> (State#, a)
-we can see that decomposing [W] (IO Int) ~R (IO Age) to
-    [W] Int ~R Age
-definitely does not lose completeness. Why not? Because the role of
-IO's argment is representational.  Hence:
-
-  DecomposeNewtypeIdea:
-     decompose [W] (N s1 .. sn) ~R (N t1 .. tn)
-     if the roles of all N's arguments are representational
-
-If N's arguments really /are/ representational this will not lose
-completeness.  Here "really are representational" means "if you expand
-all newtypes in N's RHS, we'd infer a representational role for each
-of N's type variables in that expansion".  See Note [Role inference]
-in GHC.Tc.TyCl.Utils.
-
-But the user might /override/ a phantom role with an explicit role
-annotation, and then we could (obscurely) get incompleteness.
-Consider
-
-   module A( silly, T ) where
-     newtype T a = MkT Int
-     type role T representational  -- Override phantom role
-
-     silly :: Coercion (T Int) (T Bool)
-     silly = Coercion  -- Typechecks by unwrapping the newtype
-
-     data Coercion a b where  -- Actually defined in Data.Type.Coercion
-       Coercion :: Coercible a b => Coercion a b
-
-   module B where
-     import A
-     f :: T Int -> T Bool
-     f = case silly of Coercion -> coerce
-
-Here the `coerce` gives [W] (T Int) ~R (T Bool) which, if we decompose,
-we'll get stuck with (Int ~R Bool).  Instead we want to use the
-[G] (T Int) ~R (T Bool), which will be in the Irreds.
-
-Summary: we could adopt (DecomposeNewtypeIdea), at the cost of a very
-obscure incompleteness (above).  But no one is reporting a problem from
-the lack of decompostion, so we'll just leave it for now.  This long
-Note is just to record the thinking for our future selves.
-
-Note [Decomposing AppTy equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For AppTy all the same questions arise as in
-Note [Decomposing TyConApp equalities]. We have
-
-    s1 ~r s2,  t1 ~N t2   ==>   s1 t1 ~r s2 t2       (rule CO_APP)
-    s1 t1 ~N s2 t2        ==>   s1 ~N s2,  t1 ~N t2  (CO_LEFT, CO_RIGHT)
-
-In the first of these, why do we need Nominal equality in (t1 ~N t2)?
-See {2} below.
-
-For sound and complete solving, we need both directions to decompose. So:
-* At nominal role, all is well: we have both directions.
-* At representational role, decomposition of Givens is unsound (see {1} below),
-  and decomposition of Wanteds is incomplete.
-
-Here is an example of the incompleteness for Wanteds:
-
-    [G] g1 :: a ~R b
-    [W] w1 :: Maybe b ~R alpha a
-    [W] w2 :: alpha ~N Maybe
-
-Suppose we see w1 before w2. If we decompose, using AppCo to prove w1, we get
-
-    w1 := AppCo w3 w4
-    [W] w3 :: Maybe ~R alpha
-    [W] w4 :: b ~N a
-
-Note that w4 is *nominal*. A nominal role here is necessary because AppCo
-requires a nominal role on its second argument. (See {2} for an example of
-why.) Now we are stuck, because w4 is insoluble. On the other hand, if we
-see w2 first, setting alpha := Maybe, all is well, as we can decompose
-Maybe b ~R Maybe a into b ~R a.
-
-Another example:
-    newtype Phant x = MkPhant Int
-    [W] w1 :: Phant Int ~R alpha Bool
-    [W] w2 :: alpha ~ Phant
-
-If we see w1 first, decomposing would be disastrous, as we would then try
-to solve Int ~ Bool. Instead, spotting w2 allows us to simplify w1 to become
-    [W] w1' :: Phant Int ~R Phant Bool
-
-which can then (assuming MkPhant is in scope) be simplified to Int ~R Int,
-and all will be well. See also Note [Unwrap newtypes first].
-
-Bottom line:
-* Always decompose AppTy at nominal role: can_eq_app
-* Never decompose AppTy at representational role (neither Given nor Wanted):
-  the lack of an equation in can_eq_nc'
-
-Extra points
-{1}  Decomposing a Given AppTy over a representational role is simply
-     unsound. For example, if we have co1 :: Phant Int ~R a Bool (for
-     the newtype Phant, above), then we surely don't want any relationship
-     between Int and Bool, lest we also have co2 :: Phant ~ a around.
-
-{2} The role on the AppCo coercion is a conservative choice, because we don't
-    know the role signature of the function. For example, let's assume we could
-    have a representational role on the second argument of AppCo. Then, consider
-
-    data G a where    -- G will have a nominal role, as G is a GADT
-      MkG :: G Int
-    newtype Age = MkAge Int
-
-    co1 :: G ~R a        -- by assumption
-    co2 :: Age ~R Int    -- by newtype axiom
-    co3 = AppCo co1 co2 :: G Age ~R a Int    -- by our broken AppCo
-
-    and now co3 can be used to cast MkG to have type G Age, in violation of
-    the way GADTs are supposed to work (which is to use nominal equality).
--}
-
-canDecomposableTyConAppOK :: CtEvidence -> EqRel
-                          -> TyCon -> [TcType] -> [TcType]
-                          -> TcS (StopOrContinue Ct)
--- Precondition: tys1 and tys2 are the same finite length, hence "OK"
-canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
-  = assert (tys1 `equalLength` tys2) $
-    do { traceTcS "canDecomposableTyConAppOK"
-                  (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)
-       ; case ev of
-           CtWanted { ctev_dest = dest, ctev_rewriters = rewriters }
-                  -- new_locs and tc_roles are both infinite, so
-                  -- we are guaranteed that cos has the same lengthm
-                  -- as tys1 and tys2
-                  -- See Note [Fast path when decomposing TyConApps]
-                  -- Caution: unifyWanteds is order sensitive
-                  -- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
-             -> do { cos <- unifyWanteds rewriters new_locs tc_roles tys1 tys2
-                   ; setWantedEq dest (mkTyConAppCo role tc cos) }
-
-           CtGiven { ctev_evar = evar }
-             -> do { let ev_co = mkCoVarCo evar
-                   ; given_evs <- newGivenEvVars loc $
-                                  [ ( mkPrimEqPredRole r ty1 ty2
-                                    , evCoercion $ mkSelCo (SelTyCon i r) ev_co )
-                                  | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]
-                                  , r /= Phantom
-                                  , not (isCoercionTy ty1) && not (isCoercionTy ty2) ]
-                   ; emitWorkNC given_evs }
-
-    ; stopWith ev "Decomposed TyConApp" }
-
-  where
-    loc  = ctEvLoc ev
-    role = eqRelRole eq_rel
-
-    -- Infinite, to allow for over-saturated TyConApps
-    tc_roles = tyConRoleListX role tc
-
-      -- Add nuances to the location during decomposition:
-      --  * if the argument is a kind argument, remember this, so that error
-      --    messages say "kind", not "type". This is determined based on whether
-      --    the corresponding tyConBinder is named (that is, dependent)
-      --  * if the argument is invisible, note this as well, again by
-      --    looking at the corresponding binder
-      -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't
-      -- do either of these changes. (Forgetting to do so led to #16188)
-      --
-      -- NB: infinite in length
-    new_locs = [ new_loc
-               | bndr <- tyConBinders tc
-               , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc
-                              | otherwise               = loc
-                     new_loc  | isInvisibleTyConBinder bndr
-                              = updateCtLocOrigin new_loc0 toInvisibleOrigin
-                              | otherwise
-                              = new_loc0 ]
-               ++ repeat loc
-
-canDecomposableFunTy :: CtEvidence -> EqRel -> FunTyFlag
-                     -> (Type,Type,Type)   -- (multiplicity,arg,res)
-                     -> (Type,Type,Type)   -- (multiplicity,arg,res)
-                     -> TcS (StopOrContinue Ct)
-canDecomposableFunTy ev eq_rel af f1@(m1,a1,r1) f2@(m2,a2,r2)
-  = do { traceTcS "canDecomposableFunTy"
-                  (ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2)
-       ; case ev of
-           CtWanted { ctev_dest = dest, ctev_rewriters = rewriters }
-             -> do { mult <- unifyWanted rewriters mult_loc (funRole role SelMult) m1 m2
-                   ; arg  <- unifyWanted rewriters loc      (funRole role SelArg)  a1 a2
-                   ; res  <- unifyWanted rewriters loc      (funRole role SelRes)  r1 r2
-                   ; setWantedEq dest (mkNakedFunCo1 role af mult arg res) }
-
-           CtGiven { ctev_evar = evar }
-             -> do { let ev_co = mkCoVarCo evar
-                   ; given_evs <- newGivenEvVars loc $
-                                  [ ( mkPrimEqPredRole role' ty1 ty2
-                                    , evCoercion $ mkSelCo (SelFun fs) ev_co )
-                                  | (fs, ty1, ty2) <- [(SelMult, m1, m2)
-                                                      ,(SelArg,  a1, a2)
-                                                      ,(SelRes,  r1, r2)]
-                                  , let role' = funRole role fs ]
-                   ; emitWorkNC given_evs }
-
-    ; stopWith ev "Decomposed TyConApp" }
-
-  where
-    loc      = ctEvLoc ev
-    role     = eqRelRole eq_rel
-    mult_loc = updateCtLocOrigin loc toInvisibleOrigin
-
--- | Call when canonicalizing an equality fails, but if the equality is
--- representational, there is some hope for the future.
--- Examples in Note [Use canEqFailure in canDecomposableTyConApp]
-canEqFailure :: CtEvidence -> EqRel
-             -> TcType -> TcType -> TcS (StopOrContinue Ct)
-canEqFailure ev NomEq ty1 ty2
-  = canEqHardFailure ev ty1 ty2
-canEqFailure ev ReprEq ty1 ty2
-  = do { (redn1, rewriters1) <- rewrite ev ty1
-       ; (redn2, rewriters2) <- rewrite ev ty2
-            -- We must rewrite the types before putting them in the
-            -- inert set, so that we are sure to kick them out when
-            -- new equalities become available
-       ; traceTcS "canEqFailure with ReprEq" $
-         vcat [ ppr ev, ppr redn1, ppr redn2 ]
-       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
-       ; continueWith (mkIrredCt ReprEqReason new_ev) }
-
--- | Call when canonicalizing an equality fails with utterly no hope.
-canEqHardFailure :: CtEvidence
-                 -> TcType -> TcType -> TcS (StopOrContinue Ct)
--- See Note [Make sure that insolubles are fully rewritten]
-canEqHardFailure ev ty1 ty2
-  = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)
-       ; (redn1, rewriters1) <- rewriteForErrors ev ty1
-       ; (redn2, rewriters2) <- rewriteForErrors ev ty2
-       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
-       ; continueWith (mkIrredCt ShapeMismatchReason new_ev) }
-
-{-
-Note [Canonicalising type applications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given (s1 t1) ~ ty2, how should we proceed?
-The simple thing is to see if ty2 is of form (s2 t2), and
-decompose.
-
-However, over-eager decomposition gives bad error messages
-for things like
-   a b ~ Maybe c
-   e f ~ p -> q
-Suppose (in the first example) we already know a~Array.  Then if we
-decompose the application eagerly, yielding
-   a ~ Maybe
-   b ~ c
-we get an error        "Can't match Array ~ Maybe",
-but we'd prefer to get "Can't match Array b ~ Maybe c".
-
-So instead can_eq_wanted_app rewrites the LHS and RHS, in the hope of
-replacing (a b) by (Array b), before using try_decompose_app to
-decompose it.
-
-Note [Make sure that insolubles are fully rewritten]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When an equality fails, we still want to rewrite the equality
-all the way down, so that it accurately reflects
- (a) the mutable reference substitution in force at start of solving
- (b) any ty-binds in force at this point in solving
-See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet.
-And if we don't do this there is a bad danger that
-GHC.Tc.Solver.applyTyVarDefaulting will find a variable
-that has in fact been substituted.
-
-Note [Do not decompose Given polytype equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider [G] (forall a. t1 ~ forall a. t2).  Can we decompose this?
-No -- what would the evidence look like?  So instead we simply discard
-this given evidence.
-
-Note [No top-level newtypes on RHS of representational equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we're in this situation:
-
- work item:  [W] c1 : a ~R b
-     inert:  [G] c2 : b ~R Id a
-
-where
-  newtype Id a = Id a
-
-We want to make sure canEqCanLHS sees [W] a ~R a, after b is rewritten
-and the Id newtype is unwrapped. This is assured by requiring only rewritten
-types in canEqCanLHS *and* having the newtype-unwrapping check above
-the tyvar check in can_eq_nc.
-
-Note that this only applies to saturated applications of newtype TyCons, as
-we can't rewrite an unsaturated application. See for example T22310, where
-we ended up with:
-
-  newtype Compose f g a = ...
-
-  [W] t[tau] ~# Compose Foo Bar
 
-Note [Put touchable variables on the left]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Ticket #10009, a very nasty example:
-
-    f :: (UnF (F b) ~ b) => F b -> ()
-
-    g :: forall a. (UnF (F a) ~ a) => a -> ()
-    g _ = f (undefined :: F a)
-
-For g we get [G]  g1 : UnF (F a) ~ a
-             [W] w1 : UnF (F beta) ~ beta
-             [W] w2 : F a ~ F beta
-
-g1 is canonical (CEqCan). It is oriented as above because a is not touchable.
-See canEqTyVarFunEq.
-
-w1 is similarly canonical, though the occurs-check in canEqTyVarFunEq is key
-here.
-
-w2 is canonical. But which way should it be oriented? As written, we'll be
-stuck. When w2 is added to the inert set, nothing gets kicked out: g1 is
-a Given (and Wanteds don't rewrite Givens), and w2 doesn't mention the LHS
-of w2. We'll thus lose.
-
-But if w2 is swapped around, to
-
-    [W] w3 : F beta ~ F a
-
-then we'll kick w1 out of the inert
-set (it mentions the LHS of w3). We then rewrite w1 to
-
-    [W] w4 : UnF (F a) ~ beta
-
-and then, using g1, to
-
-    [W] w5 : a ~ beta
-
-at which point we can unify and go on to glory. (This rewriting actually
-happens all at once, in the call to rewrite during canonicalisation.)
-
-But what about the new LHS makes it better? It mentions a variable (beta)
-that can appear in a Wanted -- a touchable metavariable never appears
-in a Given. On the other hand, the original LHS mentioned only variables
-that appear in Givens. We thus choose to put variables that can appear
-in Wanteds on the left.
-
-Ticket #12526 is another good example of this in action.
-
--}
-
----------------------
-canEqCanLHS :: CtEvidence            -- ev :: lhs ~ rhs
-            -> EqRel -> SwapFlag
-            -> CanEqLHS              -- lhs (or, if swapped, rhs)
-            -> TcType                -- lhs: pretty lhs, already rewritten
-            -> TcType -> TcType      -- rhs: already rewritten
-            -> TcS (StopOrContinue Ct)
-canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
-  | k1 `tcEqType` k2
-  = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
-
-  | otherwise
-  = canEqCanLHSHetero ev eq_rel swapped lhs1 k1 xi2 k2
-
-  where
-    k1 = canEqLHSKind lhs1
-    k2 = typeKind xi2
-
-
-{-
-Note [Kind Equality Orientation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-While in theory [W] x ~ y and [W] y ~ x ought to give us the same behaviour, in practice it does not.
-See Note [Fundeps with instances, and equality orientation] where this is discussed at length.
-As a rule of thumb: we keep the newest unification variables on the left of the equality.
-See also Note [Improvement orientation] in GHC.Tc.Solver.Interact.
-
-In particular, `canEqCanLHSHetero` produces the following constraint equalities
-
-[X] (xi1 :: ki1) ~ (xi2 :: ki2)
-  -->  [X] kco :: ki1 ~ ki2
-       [X] co : xi1 :: ki1 ~ (xi2 |> sym kco) :: ki1
-
-Note that the types in the LHS of the new constraints are the ones that were on the LHS of
-the original constraint.
-
---- Historical note ---
-We prevously used to flip the kco to avoid using a sym in the cast
-
-[X] (xi1 :: ki1) ~ (xi2 :: ki2)
-  -->  [X] kco :: ki2 ~ ki1
-       [X] co : xi1 :: ki1 ~ (xi2 |> kco) :: ki1
-
-But this sent solver in an infinite loop (see #19415).
--- End of historical note --
--}
-
-canEqCanLHSHetero :: CtEvidence         -- :: (xi1 :: ki1) ~ (xi2 :: ki2)
-                  -> EqRel -> SwapFlag
-                  -> CanEqLHS           -- xi1
-                  -> TcKind             -- ki1
-                  -> TcType             -- xi2
-                  -> TcKind             -- ki2
-                  -> TcS (StopOrContinue Ct)
-canEqCanLHSHetero ev eq_rel swapped lhs1 ki1 xi2 ki2
-  -- See Note [Equalities with incompatible kinds]
-  -- See Note [Kind Equality Orientation]
-  -- NB: preserve left-to-right orientation!!
-  -- See Note [Fundeps with instances, and equality orientation]
-  --     wrinkle (W2) in GHC.Tc.Solver.Interact
-  = do { (kind_ev, kind_co) <- mk_kind_eq   -- :: ki1 ~N ki2
-
-       ; let  -- kind_co :: (ki1 :: *) ~N (ki2 :: *)   (whether swapped or not)
-             lhs_redn = mkReflRedn role xi1
-             rhs_redn = mkGReflRightRedn role xi2 (mkSymCo kind_co)
-
-             -- See Note [Equalities with incompatible kinds], Wrinkle (1)
-             -- This will be ignored in rewriteEqEvidence if the work item is a Given
-             rewriters = rewriterSetFromCo kind_co
-
-       ; traceTcS "Hetero equality gives rise to kind equality"
-           (ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ])
-       ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn
-
-       ; emitWorkNC [type_ev]  -- delay the type equality until after we've finished
-                               -- the kind equality, which may unlock things
-                               -- See Note [Equalities with incompatible kinds]
-
-       ; canEqNC kind_ev NomEq ki1 ki2 }
-  where
-    mk_kind_eq :: TcS (CtEvidence, CoercionN)
-    mk_kind_eq = case ev of
-      CtGiven { ctev_evar = evar }
-        -> do { let kind_co = maybe_sym $ mkKindCo (mkCoVarCo evar) -- :: k1 ~ k2
-              ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)
-              ; return (kind_ev, ctEvCoercion kind_ev) }
-
-      CtWanted { ctev_rewriters = rewriters }
-        -> newWantedEq kind_loc rewriters Nominal ki1 ki2
-
-    xi1      = canEqLHSType lhs1
-    loc      = ctev_loc ev
-    role     = eqRelRole eq_rel
-    kind_loc = mkKindLoc xi1 xi2 loc
-    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki1 ki2
-
-    maybe_sym = case swapped of
-          IsSwapped  -> mkSymCo         -- if the input is swapped, then we
-                                        -- will have k2 ~ k1, so flip it to k1 ~ k2
-          NotSwapped -> id
-
--- guaranteed that typeKind lhs == typeKind rhs
-canEqCanLHSHomo :: CtEvidence
-                -> EqRel -> SwapFlag
-                -> CanEqLHS           -- lhs (or, if swapped, rhs)
-                -> TcType             -- pretty lhs
-                -> TcType -> TcType   -- rhs, pretty rhs
-                -> TcS (StopOrContinue Ct)
-canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
-  | (xi2', mco) <- split_cast_ty xi2
-  , Just lhs2 <- canEqLHS_maybe xi2'
-  = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkSymMCo mco) mco
-
-  | otherwise
-  = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2
-
-  where
-    split_cast_ty (CastTy ty co) = (ty, MCo co)
-    split_cast_ty other          = (other, MRefl)
-
--- This function deals with the case that both LHS and RHS are potential
--- CanEqLHSs.
-canEqCanLHS2 :: CtEvidence              -- lhs ~ (rhs |> mco)
-                                        -- or, if swapped: (rhs |> mco) ~ lhs
-             -> EqRel -> SwapFlag
-             -> CanEqLHS                -- lhs (or, if swapped, rhs)
-             -> TcType                  -- pretty lhs
-             -> CanEqLHS                -- rhs
-             -> TcType                  -- pretty rhs
-             -> MCoercion               -- :: kind(rhs) ~N kind(lhs)
-             -> TcS (StopOrContinue Ct)
-canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco
-  | lhs1 `eqCanEqLHS` lhs2
-    -- It must be the case that mco is reflexive
-  = canEqReflexive ev eq_rel (canEqLHSType lhs1)
-
-  | TyVarLHS tv1 <- lhs1
-  , TyVarLHS tv2 <- lhs2
-  , swapOverTyVars (isGiven ev) tv1 tv2
-  = do { traceTcS "canEqLHS2 swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)
-       ; new_ev <- do_swap
-       ; canEqCanLHSFinish new_ev eq_rel IsSwapped (TyVarLHS tv2)
-                                                   (ps_xi1 `mkCastTyMCo` sym_mco) }
-
-  | TyVarLHS tv1 <- lhs1
-  , TyFamLHS fun_tc2 fun_args2 <- lhs2
-  = canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco
-
-  | TyFamLHS fun_tc1 fun_args1 <- lhs1
-  , TyVarLHS tv2 <- lhs2
-  = do { new_ev <- do_swap
-       ; canEqTyVarFunEq new_ev eq_rel IsSwapped tv2 ps_xi2
-                                                 fun_tc1 fun_args1 ps_xi1 sym_mco }
-
-  | TyFamLHS fun_tc1 fun_args1 <- lhs1
-  , TyFamLHS fun_tc2 fun_args2 <- lhs2
-  -- See Note [Decomposing type family applications]
-  = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2)
-
-         -- emit wanted equalities for injective type families
-       ; let inj_eqns :: [TypeEqn]  -- TypeEqn = Pair Type
-             inj_eqns
-               | ReprEq <- eq_rel   = []   -- injectivity applies only for nom. eqs.
-               | fun_tc1 /= fun_tc2 = []   -- if the families don't match, stop.
-
-               | Injective inj <- tyConInjectivityInfo fun_tc1
-               = [ Pair arg1 arg2
-                 | (arg1, arg2, True) <- zip3 fun_args1 fun_args2 inj ]
-
-                 -- built-in synonym families don't have an entry point
-                 -- for this use case. So, we just use sfInteractInert
-                 -- and pass two equal RHSs. We *could* add another entry
-                 -- point, but then there would be a burden to make
-                 -- sure the new entry point and existing ones were
-                 -- internally consistent. This is slightly distasteful,
-                 -- but it works well in practice and localises the
-                 -- problem.
-               | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc1
-               = let ki1 = canEqLHSKind lhs1
-                     ki2 | MRefl <- mco
-                         = ki1   -- just a small optimisation
-                         | otherwise
-                         = canEqLHSKind lhs2
-
-                     fake_rhs1 = anyTypeOfKind ki1
-                     fake_rhs2 = anyTypeOfKind ki2
-                 in
-                 sfInteractInert ops fun_args1 fake_rhs1 fun_args2 fake_rhs2
-
-               | otherwise  -- ordinary, non-injective type family
-               = []
-
-       ; case ev of
-           CtWanted { ctev_rewriters = rewriters } ->
-             mapM_ (\ (Pair t1 t2) -> unifyWanted rewriters (ctEvLoc ev) Nominal t1 t2) inj_eqns
-           CtGiven {} -> return ()
-             -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Interact
-
-       ; tclvl <- getTcLevel
-       ; let tvs1 = tyCoVarsOfTypes fun_args1
-             tvs2 = tyCoVarsOfTypes fun_args2
-
-             swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 &&
-                          -- swap 'em: Note [Put touchable variables on the left]
-                                  not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1)
-                          -- this check is just to avoid unfruitful swapping
-
-               -- If we have F a ~ F (F a), we want to swap.
-             swap_for_occurs
-               | cterHasNoProblem   $ checkTyFamEq fun_tc2 fun_args2
-                                                   (mkTyConApp fun_tc1 fun_args1)
-               , cterHasOccursCheck $ checkTyFamEq fun_tc1 fun_args1
-                                                   (mkTyConApp fun_tc2 fun_args2)
-               = True
-
-               | otherwise
-               = False
-
-       ; if swap_for_rewriting || swap_for_occurs
-         then do { new_ev <- do_swap
-                 ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) }
-         else finish_without_swapping }
-
-  -- that's all the special cases. Now we just figure out which non-special case
-  -- to continue to.
-  | otherwise
-  = finish_without_swapping
-
-  where
-    sym_mco = mkSymMCo mco
-
-    do_swap = rewriteCastedEquality ev eq_rel swapped (canEqLHSType lhs1) (canEqLHSType lhs2) mco
-    finish_without_swapping = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco)
-
-
--- This function handles the case where one side is a tyvar and the other is
--- a type family application. Which to put on the left?
---   If the tyvar is a touchable meta-tyvar, put it on the left, as this may
---   be our only shot to unify.
---   Otherwise, put the function on the left, because it's generally better to
---   rewrite away function calls. This makes types smaller. And it seems necessary:
---     [W] F alpha ~ alpha
---     [W] F alpha ~ beta
---     [W] G alpha beta ~ Int   ( where we have type instance G a a = a )
---   If we end up with a stuck alpha ~ F alpha, we won't be able to solve this.
---   Test case: indexed-types/should_compile/CEqCanOccursCheck
-canEqTyVarFunEq :: CtEvidence               -- :: lhs ~ (rhs |> mco)
-                                            -- or (rhs |> mco) ~ lhs if swapped
-                -> EqRel -> SwapFlag
-                -> TyVar -> TcType          -- lhs (or if swapped rhs), pretty lhs
-                -> TyCon -> [Xi] -> TcType  -- rhs (or if swapped lhs) fun and args, pretty rhs
-                -> MCoercion                -- :: kind(rhs) ~N kind(lhs)
-                -> TcS (StopOrContinue Ct)
-canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco
-  = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs
-       ; if | case is_touchable of { Untouchable -> False; _ -> True }
-            , cterHasNoProblem $
-                checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily
-            -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1) rhs
-
-            | otherwise
-              -> do { new_ev <- rewriteCastedEquality ev eq_rel swapped
-                                  (mkTyVarTy tv1) (mkTyConApp fun_tc2 fun_args2)
-                                  mco
-                    ; canEqCanLHSFinish new_ev eq_rel IsSwapped
-                                  (TyFamLHS fun_tc2 fun_args2)
-                                  (ps_xi1 `mkCastTyMCo` sym_mco) } }
-  where
-    sym_mco = mkSymMCo mco
-    rhs = ps_xi2 `mkCastTyMCo` mco
-
--- The RHS here is either not CanEqLHS, or it's one that we
--- want to rewrite the LHS to (as per e.g. swapOverTyVars)
-canEqCanLHSFinish :: CtEvidence
-                  -> EqRel -> SwapFlag
-                  -> CanEqLHS             -- lhs (or, if swapped, rhs)
-                  -> TcType               -- rhs (or, if swapped, lhs)
-                  -> TcS (StopOrContinue Ct)
-canEqCanLHSFinish ev eq_rel swapped lhs rhs
--- RHS is fully rewritten, but with type synonyms
--- preserved as much as possible
--- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K)
--- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqCanLHS2
-
-  = do {
-          -- this performs the swap if necessary
-         new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
-                                     (mkReflRedn role lhs_ty)
-                                     (mkReflRedn role rhs)
-
-     -- by now, (TyEq:K) is already satisfied
-       ; massert (canEqLHSKind lhs `eqType` typeKind rhs)
-
-     -- by now, (TyEq:N) is already satisfied (if applicable)
-       ; assertPprM ty_eq_N_OK $
-           vcat [ text "CanEqCanLHSFinish: (TyEq:N) not satisfied"
-                , text "rhs:" <+> ppr rhs
-                ]
-
-     -- guarantees (TyEq:OC), (TyEq:F)
-     -- Must do the occurs check even on tyvar/tyvar
-     -- equalities, in case have  x ~ (y :: ..x...); this is #12593.
-       ; let result0 = checkTypeEq lhs rhs `cterRemoveProblem` cteTypeFamily
-     -- type families are OK here
-     -- NB: no occCheckExpand here; see Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite
-
-              -- a ~R# b a is soluble if b later turns out to be Identity
-             result = case eq_rel of
-                        NomEq  -> result0
-                        ReprEq -> cterSetOccursCheckSoluble result0
-
-             reason = NonCanonicalReason result
-
-       ; if cterHasNoProblem result
-         then do { traceTcS "CEqCan" (ppr lhs $$ ppr rhs)
-                 ; continueWith (CEqCan { cc_ev = new_ev, cc_lhs = lhs
-                                        , cc_rhs = rhs, cc_eq_rel = eq_rel }) }
-
-         else do { m_stuff <- breakTyEqCycle_maybe ev result lhs rhs
-                           -- See Note [Type equality cycles];
-                           -- returning Nothing is the vastly common case
-                 ; case m_stuff of
-                     { Nothing ->
-                         do { traceTcS "canEqCanLHSFinish can't make a canonical"
-                                       (ppr lhs $$ ppr rhs)
-                            ; continueWith (mkIrredCt reason new_ev) }
-                     ; Just rhs_redn@(Reduction _ new_rhs) ->
-              do { traceTcS "canEqCanLHSFinish breaking a cycle" $
-                            ppr lhs $$ ppr rhs
-                 ; traceTcS "new RHS:" (ppr new_rhs)
-
-                   -- This check is Detail (1) in the Note
-                 ; if cterHasOccursCheck (checkTypeEq lhs new_rhs)
-
-                   then do { traceTcS "Note [Type equality cycles] Detail (1)"
-                                      (ppr new_rhs)
-                           ; continueWith (mkIrredCt reason new_ev) }
-
-                   else do { -- See Detail (6) of Note [Type equality cycles]
-                             new_new_ev <- rewriteEqEvidence emptyRewriterSet
-                                             new_ev NotSwapped
-                                             (mkReflRedn Nominal lhs_ty)
-                                             rhs_redn
-
-                           ; continueWith (CEqCan { cc_ev = new_new_ev
-                                                  , cc_lhs = lhs
-                                                  , cc_rhs = new_rhs
-                                                  , cc_eq_rel = eq_rel }) }}}}}
-  where
-    role = eqRelRole eq_rel
-
-    lhs_ty = canEqLHSType lhs
-
-    -- This is about (TyEq:N): check that we don't have a saturated application
-    -- of a newtype TyCon at the top level of the RHS, if the constructor
-    -- of the newtype is in scope.
-    ty_eq_N_OK :: TcS Bool
-    ty_eq_N_OK
-      | ReprEq <- eq_rel
-      , Just (tc, tc_args) <- splitTyConApp_maybe rhs
-      , Just con <- newTyConDataCon_maybe tc
-      -- #22310: only a problem if the newtype TyCon is saturated.
-      , tc_args `lengthAtLeast` tyConArity tc
-      -- #21010: only a problem if the newtype constructor is in scope.
-      = do { rdr_env <- getGlobalRdrEnvTcS
-           ; let con_in_scope = isJust $ lookupGRE_Name rdr_env (dataConName con)
-           ; return $ not con_in_scope }
-      | otherwise
-      = return True
-
--- | Solve a reflexive equality constraint
-canEqReflexive :: CtEvidence    -- ty ~ ty
-               -> EqRel
-               -> TcType        -- ty
-               -> TcS (StopOrContinue Ct)   -- always Stop
-canEqReflexive ev eq_rel ty
-  = do { setEvBindIfWanted ev IsCoherent (evCoercion $ mkReflCo (eqRelRole eq_rel) ty)
-       ; stopWith ev "Solved by reflexivity" }
-
-rewriteCastedEquality :: CtEvidence     -- :: lhs ~ (rhs |> mco), or (rhs |> mco) ~ lhs
-                      -> EqRel -> SwapFlag
-                      -> TcType         -- lhs
-                      -> TcType         -- rhs
-                      -> MCoercion      -- mco
-                      -> TcS CtEvidence -- :: (lhs |> sym mco) ~ rhs
-                                        -- result is independent of SwapFlag
-rewriteCastedEquality ev eq_rel swapped lhs rhs mco
-  = rewriteEqEvidence emptyRewriterSet ev swapped lhs_redn rhs_redn
-  where
-    lhs_redn = mkGReflRightMRedn role lhs sym_mco
-    rhs_redn = mkGReflLeftMRedn  role rhs mco
-
-    sym_mco = mkSymMCo mco
-    role    = eqRelRole eq_rel
-
-{- Note [Equalities with incompatible kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What do we do when we have an equality
-
-  (tv :: k1) ~ (rhs :: k2)
-
-where k1 and k2 differ? Easy: we create a coercion that relates k1 and
-k2 and use this to cast. To wit, from
-
-  [X] (tv :: k1) ~ (rhs :: k2)
-
-(where [X] is [G] or [W]), we go to
-
-  [X] co :: k1 ~ k2
-  [X] (tv :: k1) ~ ((rhs |> sym co) :: k1)
-
-We carry on with the *kind equality*, not the type equality, because
-solving the former may unlock the latter. This choice is made in
-canEqCanLHSHetero. It is important: otherwise, T13135 loops.
-
-Wrinkles:
-
- (1) When X is W, the new type-level wanted is effectively rewritten by the
-     kind-level one. We thus include the kind-level wanted in the RewriterSet
-     for the type-level one. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint.
-     This is done in canEqCanLHSHetero.
-
- (2) If we have [W] w :: alpha ~ (rhs |> sym co_hole), should we unify alpha? No.
-     The problem is that the wanted w is effectively rewritten by another wanted,
-     and unifying alpha effectively promotes this wanted to a given. Doing so
-     means we lose track of the rewriter set associated with the wanted.
-
-     On the other hand, w is perfectly suitable for rewriting, because of the
-     way we carefully track rewriter sets.
-
-     We thus allow w to be a CEqCan, but we prevent unification. See
-     Note [Unification preconditions] in GHC.Tc.Utils.Unify.
-
-     The only tricky part is that we must later indeed unify if/when the kind-level
-     wanted gets solved. This is done in kickOutAfterFillingCoercionHole,
-     which kicks out all equalities whose RHS mentions the filled-in coercion hole.
-     Note that it looks for type family equalities, too, because of the use of
-     unifyTest in canEqTyVarFunEq.
-
- (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the
-     algorithm detailed here, producing [W] co :: k1 ~ k2, and adding
-     [W] (a :: k1) ~ ((rhs |> sym co) :: k1) to the irreducibles. Some time
-     later, we solve co, and fill in co's coercion hole. This kicks out
-     the irreducible as described in (2).
-     But now, during canonicalization, we see the cast
-     and remove it, in canEqCast. By the time we get into canEqCanLHS, the equality
-     is heterogeneous again, and the process repeats.
-
-     To avoid this, we don't strip casts off a type if the other type
-     in the equality is a CanEqLHS (the scenario above can happen with a
-     type family, too. testcase: typecheck/should_compile/T13822).
-     And this is an improvement regardless:
-     because tyvars can, generally, unify with casted types, there's no
-     reason to go through the work of stripping off the cast when the
-     cast appears opposite a tyvar. This is implemented in the cast case
-     of can_eq_nc'.
-
-Historical note:
-
-We used to do this via emitting a Derived kind equality and then parking
-the heterogeneous equality as irreducible. But this new approach is much
-more direct. And it doesn't produce duplicate Deriveds (as the old one did).
-
-Note [Type synonyms and canonicalization]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We treat type synonym applications as xi types, that is, they do not
-count as type function applications.  However, we do need to be a bit
-careful with type synonyms: like type functions they may not be
-generative or injective.  However, unlike type functions, they are
-parametric, so there is no problem in expanding them whenever we see
-them, since we do not need to know anything about their arguments in
-order to expand them; this is what justifies not having to treat them
-as specially as type function applications.  The thing that causes
-some subtleties is that we prefer to leave type synonym applications
-*unexpanded* whenever possible, in order to generate better error
-messages.
-
-If we encounter an equality constraint with type synonym applications
-on both sides, or a type synonym application on one side and some sort
-of type application on the other, we simply must expand out the type
-synonyms in order to continue decomposing the equality constraint into
-primitive equality constraints.  For example, suppose we have
-
-  type F a = [Int]
-
-and we encounter the equality
-
-  F a ~ [b]
-
-In order to continue we must expand F a into [Int], giving us the
-equality
-
-  [Int] ~ [b]
-
-which we can then decompose into the more primitive equality
-constraint
-
-  Int ~ b.
-
-However, if we encounter an equality constraint with a type synonym
-application on one side and a variable on the other side, we should
-NOT (necessarily) expand the type synonym, since for the purpose of
-good error messages we want to leave type synonyms unexpanded as much
-as possible.  Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS.
-
-Note [Type equality cycles]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this situation (from indexed-types/should_compile/GivenLoop):
-
-  instance C (Maybe b)
-  *[G] a ~ Maybe (F a)
-  [W] C a
-
-or (typecheck/should_compile/T19682b):
-
-  instance C (a -> b)
-  *[W] alpha ~ (Arg alpha -> Res alpha)
-  [W] C alpha
-
-or (typecheck/should_compile/T21515):
-
-  type family Code a
-  *[G] Code a ~ '[ '[ Head (Head (Code a)) ] ]
-  [W] Code a ~ '[ '[ alpha ] ]
-
-In order to solve the final Wanted, we must use the starred constraint
-for rewriting. But note that all starred constraints have occurs-check failures,
-and so we can't straightforwardly add these to the inert set and
-use them for rewriting. (NB: A rigid type constructor is at the
-top of all RHSs, preventing reorienting in canEqTyVarFunEq in the tyvar
-cases.)
-
-The key idea is to replace the outermost type family applications in the RHS of the
-starred constraints with a fresh variable, which we'll call a cycle-breaker
-variable, or cbv. Then, relate the cbv back with the original type family application
-via new equality constraints. Our situations thus become:
-
-  instance C (Maybe b)
-  [G] a ~ Maybe cbv
-  [G] F a ~ cbv
-  [W] C a
-
-or
-
-  instance C (a -> b)
-  [W] alpha ~ (cbv1 -> cbv2)
-  [W] Arg alpha ~ cbv1
-  [W] Res alpha ~ cbv2
-  [W] C alpha
-
-or
-
-  [G] Code a ~ '[ '[ cbv ] ]
-  [G] Head (Head (Code a)) ~ cbv
-  [W] Code a ~ '[ '[ alpha ] ]
-
-This transformation (creating the new types and emitting new equality
-constraints) is done in breakTyEqCycle_maybe.
-
-The details depend on whether we're working with a Given or a Wanted.
-
-Given
------
-
-We emit a new Given, [G] F a ~ cbv, equating the type family application to
-our new cbv. Note its orientation: The type family ends up on the left; see
-commentary on canEqTyVarFunEq, which decides how to orient such cases. No
-special treatment for CycleBreakerTvs is necessary. This scenario is now
-easily soluble, by using the first Given to rewrite the Wanted, which can now
-be solved.
-
-(The first Given actually also rewrites the second one, giving
-[G] F (Maybe cbv) ~ cbv, but this causes no trouble.)
-
-Of course, we don't want our fresh variables leaking into e.g. error messages.
-So we fill in the metavariables with their original type family applications
-after we're done running the solver (in nestImplicTcS and runTcSWithEvBinds).
-This is done by restoreTyVarCycles, which uses the inert_cycle_breakers field in
-InertSet, which contains the pairings invented in breakTyEqCycle_maybe.
-
-That is:
-
-We transform
-  [G] g : lhs ~ ...(F lhs)...
-to
-  [G] (Refl lhs) : F lhs ~ cbv      -- CEqCan
-  [G] g          : lhs ~ ...cbv...  -- CEqCan
-
-Note that
-* `cbv` is a fresh cycle breaker variable.
-* `cbv` is a is a meta-tyvar, but it is completely untouchable.
-* We track the cycle-breaker variables in inert_cycle_breakers in InertSet
-* We eventually fill in the cycle-breakers, with `cbv := F lhs`.
-  No one else fills in cycle-breakers!
-* The evidence for the new `F lhs ~ cbv` constraint is Refl, because we know
-  this fill-in is ultimately going to happen.
-* In inert_cycle_breakers, we remember the (cbv, F lhs) pair; that is, we
-  remember the /original/ type.  The [G] F lhs ~ cbv constraint may be rewritten
-  by other givens (eg if we have another [G] lhs ~ (b,c)), but at the end we
-  still fill in with cbv := F lhs
-* This fill-in is done when solving is complete, by restoreTyVarCycles
-  in nestImplicTcS and runTcSWithEvBinds.
-
-Wanted
-------
-The fresh cycle-breaker variables here must actually be normal, touchable
-metavariables. That is, they are TauTvs. Nothing at all unusual. Repeating
-the example from above, we have
-
-  *[W] alpha ~ (Arg alpha -> Res alpha)
-
-and we turn this into
-
-  *[W] alpha ~ (cbv1 -> cbv2)
-  [W] Arg alpha ~ cbv1
-  [W] Res alpha ~ cbv2
-
-where cbv1 and cbv2 are fresh TauTvs. Why TauTvs? See [Why TauTvs] below.
-
-Critically, we emit the two new constraints (the last two above)
-directly instead of calling unifyWanted. (Otherwise, we'd end up unifying cbv1
-and cbv2 immediately, achieving nothing.)
-Next, we unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This
-unification -- which must be the next step after breaking the cycles --
-happens in the course of normal behavior of top-level
-interactions, later in the solver pipeline. We know this unification will
-indeed happen because breakTyEqCycle_maybe, which decides whether to apply
-this logic, checks to ensure unification will succeed in its final_check.
-(In particular, the LHS must be a touchable tyvar, never a type family. We don't
-yet have an example of where this logic is needed with a type family, and it's
-unclear how to handle this case, so we're skipping for now.) Now, we're
-here (including further context from our original example, from the top of the
-Note):
-
-  instance C (a -> b)
-  [W] Arg (cbv1 -> cbv2) ~ cbv1
-  [W] Res (cbv1 -> cbv2) ~ cbv2
-  [W] C (cbv1 -> cbv2)
-
-The first two W constraints reduce to reflexivity and are discarded,
-and the last is easily soluble.
-
-[Why TauTvs]:
-Let's look at another example (typecheck/should_compile/T19682) where we need
-to unify the cbvs:
-
-  class    (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys
-  instance (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys
-
-  type family SameShapeAs xs ys :: Constraint where
-    SameShapeAs '[] ys      = (ys ~ '[])
-    SameShapeAs (x : xs) ys = (ys ~ (Head ys : Tail ys))
-
-  type family AllEqF xs ys :: Constraint where
-    AllEqF '[]      '[]      = ()
-    AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys)
-
-  [W] alpha ~ (Head alpha : Tail alpha)
-  [W] AllEqF '[Bool] alpha
-
-Without the logic detailed in this Note, we're stuck here, as AllEqF cannot
-reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach,
-just as described above. We thus invent cbv1 and cbv2 and unify
-alpha := cbv1 -> cbv2, yielding (after zonking)
-
-  [W] Head (cbv1 : cbv2) ~ cbv1
-  [W] Tail (cbv1 : cbv2) ~ cbv2
-  [W] AllEqF '[Bool] (cbv1 : cbv2)
-
-The first two W constraints simplify to reflexivity and are discarded.
-But the last reduces:
-
-  [W] Bool ~ cbv1
-  [W] AllEq '[] cbv2
-
-The first of these is solved by unification: cbv1 := Bool. The second
-is solved by the instance for AllEq to become
-
-  [W] AllEqF '[] cbv2
-  [W] SameShapeAs '[] cbv2
-
-While the first of these is stuck, the second makes progress, to lead to
-
-  [W] AllEqF '[] cbv2
-  [W] cbv2 ~ '[]
-
-This second constraint is solved by unification: cbv2 := '[]. We now
-have
-
-  [W] AllEqF '[] '[]
-
-which reduces to
-
-  [W] ()
-
-which is trivially satisfiable. Hooray!
-
-Note that we need to unify the cbvs here; if we did not, there would be
-no way to solve those constraints. That's why the cycle-breakers are
-ordinary TauTvs.
-
-In all cases
-------------
-
-We detect this scenario by the following characteristics:
- - a constraint with a soluble occurs-check failure
-   (as indicated by the cteSolubleOccurs bit set in a CheckTyEqResult
-   from checkTypeEq)
- - and a nominal equality
- - and either
-    - a Given flavour (but see also Detail (7) below)
-    - a Wanted flavour, with a touchable metavariable on the left
-
-We don't use this trick for representational equalities, as there is no
-concrete use case where it is helpful (unlike for nominal equalities).
-Furthermore, because function applications can be CanEqLHSs, but newtype
-applications cannot, the disparities between the cases are enough that it
-would be effortful to expand the idea to representational equalities. A quick
-attempt, with
-
-      data family N a b
-
-      f :: (Coercible a (N a b), Coercible (N a b) b) => a -> b
-      f = coerce
-
-failed with "Could not match 'b' with 'b'." Further work is held off
-until when we have a concrete incentive to explore this dark corner.
-
-Details:
-
- (1) We don't look under foralls, at all, when substituting away type family
-     applications, because doing so can never be fruitful. Recall that we
-     are in a case like [G] lhs ~ forall b. ... lhs ....   Until we have a type
-     family that can pull the body out from a forall (e.g. type instance F (forall b. ty) = ty),
-     this will always be
-     insoluble. Note also that the forall cannot be in an argument to a
-     type family, or that outer type family application would already have
-     been substituted away.
-
-     However, we still must check to make sure that breakTyEqCycle_maybe actually
-     succeeds in getting rid of all occurrences of the offending lhs. If
-     one is hidden under a forall, this won't be true. A similar problem can
-     happen if the variable appears only in a kind
-     (e.g. k ~ ... (a :: k) ...). So we perform an additional check after
-     performing the substitution. It is tiresome to re-run all of checkTypeEq
-     here, but reimplementing just the occurs-check is even more tiresome.
-
-     Skipping this check causes typecheck/should_fail/GivenForallLoop and
-     polykinds/T18451 to loop.
-
- (2) Our goal here is to avoid loops in rewriting. We can thus skip looking
-     in coercions, as we don't rewrite in coercions in the algorithm in
-     GHC.Solver.Rewrite. (This is another reason
-     we need to re-check that we've gotten rid of all occurrences of the
-     offending variable.)
-
- (3) As we're substituting as described in this Note, we can build ill-kinded
-     types. For example, if we have Proxy (F a) b, where (b :: F a), then
-     replacing this with Proxy cbv b is ill-kinded. However, we will later
-     set cbv := F a, and so the zonked type will be well-kinded again.
-     The temporary ill-kinded type hurts no one, and avoiding this would
-     be quite painfully difficult.
-
-     Specifically, this detail does not contravene the Purely Kinded Type Invariant
-     (Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType).
-     The PKTI says that we can call typeKind on any type, without failure.
-     It would be violated if we, say, replaced a kind (a -> b) with a kind c,
-     because an arrow kind might be consulted in piResultTys. Here, we are
-     replacing one opaque type like (F a b c) with another, cbv (opaque in
-     that we never assume anything about its structure, like that it has a
-     result type or a RuntimeRep argument).
-
- (4) The evidence for the produced Givens is all just reflexive, because
-     we will eventually set the cycle-breaker variable to be the type family,
-     and then, after the zonk, all will be well. See also the notes at the
-     end of the Given section of this Note.
-
- (5) The approach here is inefficient because it replaces every (outermost)
-     type family application with a type variable, regardless of whether that
-     particular appplication is implicated in the occurs check.  An alternative
-     would be to replce only type-family applications that mention the offending LHS.
-     For instance, we could choose to
-     affect only type family applications that mention the offending LHS:
-     e.g. in a ~ (F b, G a), we need to replace only G a, not F b. Furthermore,
-     we could try to detect cases like a ~ (F a, F a) and use the same
-     tyvar to replace F a. (Cf.
-     Note [Flattening type-family applications when matching instances]
-     in GHC.Core.Unify, which
-     goes to this extra effort.) There may be other opportunities for
-     improvement. However, this is really a very small corner case.
-     The investment to craft a clever,
-     performant solution seems unworthwhile.
-
- (6) We often get the predicate associated with a constraint from its
-     evidence with ctPred. We thus must not only make sure the generated
-     CEqCan's fields have the updated RHS type (that is, the one produced
-     by replacing type family applications with fresh variables),
-     but we must also update the evidence itself. This is done by the call to rewriteEqEvidence
-     in canEqCanLHSFinish.
-
- (7) We don't wish to apply this magic on the equalities created
-     by this very same process.
-     Consider this, from typecheck/should_compile/ContextStack2:
-
-       type instance TF (a, b) = (TF a, TF b)
-       t :: (a ~ TF (a, Int)) => ...
-
-       [G] a ~ TF (a, Int)
-
-     The RHS reduces, so we get
-
-       [G] a ~ (TF a, TF Int)
-
-     We then break cycles, to get
-
-       [G] g1 :: a ~ (cbv1, cbv2)
-       [G] g2 :: TF a ~ cbv1
-       [G] g3 :: TF Int ~ cbv2
-
-     g1 gets added to the inert set, as written. But then g2 becomes
-     the work item. g1 rewrites g2 to become
-
-       [G] TF (cbv1, cbv2) ~ cbv1
-
-     which then uses the type instance to become
-
-       [G] (TF cbv1, TF cbv2) ~ cbv1
-
-     which looks remarkably like the Given we started with. If left
-     unchecked, this will end up breaking cycles again, looping ad
-     infinitum (and resulting in a context-stack reduction error,
-     not an outright loop). The solution is easy: don't break cycles
-     on an equality generated by breaking cycles. Instead, we mark this
-     final Given as a CIrredCan with a NonCanonicalReason with the soluble
-     occurs-check bit set (only).
-
-     We track these equalities by giving them a special CtOrigin,
-     CycleBreakerOrigin. This works for both Givens and Wanteds, as
-     we need the logic in the W case for e.g. typecheck/should_fail/T17139.
-     Because this logic needs to work for Wanteds, too, we cannot
-     simply look for a CycleBreakerTv on the left: Wanteds don't use them.
-
- (8) We really want to do this all only when there is a soluble occurs-check
-     failure, not when other problems arise (such as an impredicative
-     equality like alpha ~ forall a. a -> a). That is why breakTyEqCycle_maybe
-     uses cterHasOnlyProblem when looking at the result of checkTypeEq, which
-     checks for many of the invariants on a CEqCan.
--}
-
-{-
 ************************************************************************
 *                                                                      *
                   Evidence transformation
@@ -3166,35 +975,6 @@ Details:
 ************************************************************************
 -}
 
-data StopOrContinue a
-  = ContinueWith a    -- The constraint was not solved, although it may have
-                      --   been rewritten
-
-  | Stop CtEvidence   -- The (rewritten) constraint was solved
-         SDoc         -- Tells how it was solved
-                      -- Any new sub-goals have been put on the work list
-  deriving (Functor)
-
-instance Outputable a => Outputable (StopOrContinue a) where
-  ppr (Stop ev s)      = text "Stop" <> parens s <+> ppr ev
-  ppr (ContinueWith w) = text "ContinueWith" <+> ppr w
-
-continueWith :: a -> TcS (StopOrContinue a)
-continueWith = return . ContinueWith
-
-stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)
-stopWith ev s = return (Stop ev (text s))
-
-andWhenContinue :: TcS (StopOrContinue a)
-                -> (a -> TcS (StopOrContinue b))
-                -> TcS (StopOrContinue b)
-andWhenContinue tcs1 tcs2
-  = do { r <- tcs1
-       ; case r of
-           Stop ev s       -> return (Stop ev s)
-           ContinueWith ct -> tcs2 ct }
-infixr 0 `andWhenContinue`    -- allow chaining with ($)
-
 rewriteEvidence :: RewriterSet  -- ^ See Note [Wanteds rewrite Wanteds]
                                 -- in GHC.Tc.Types.Constraint
                 -> CtEvidence   -- ^ old evidence
@@ -3267,188 +1047,3 @@ rewriteEvidence new_rewriters
             Cached _      -> stopWith ev "Cached wanted" }
   where
     rewriters' = rewriters S.<> new_rewriters
-
-
-rewriteEqEvidence :: RewriterSet        -- New rewriters
-                                        -- See GHC.Tc.Types.Constraint
-                                        -- Note [Wanteds rewrite Wanteds]
-                  -> CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)
-                                        --              or orhs ~ olhs (swapped)
-                  -> SwapFlag
-                  -> Reduction          -- lhs_co :: olhs ~ nlhs
-                  -> Reduction          -- rhs_co :: orhs ~ nrhs
-                  -> TcS CtEvidence     -- Of type nlhs ~ nrhs
--- With reductions (Reduction lhs_co nlhs) (Reduction rhs_co nrhs),
--- rewriteEqEvidence yields, for a given equality (Given g olhs orhs):
--- If not swapped
---      g1 : nlhs ~ nrhs = sym lhs_co ; g ; rhs_co
--- If swapped
---      g1 : nlhs ~ nrhs = sym lhs_co ; Sym g ; rhs_co
---
--- For a wanted equality (Wanted w), we do the dual thing:
--- New  w1 : nlhs ~ nrhs
--- If not swapped
---      w : olhs ~ orhs = lhs_co ; w1 ; sym rhs_co
--- If swapped
---      w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co
---
--- It's all a form of rewriteEvidence, specialised for equalities
-rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs)
-  | NotSwapped <- swapped
-  , isReflCo lhs_co      -- See Note [Rewriting with Refl]
-  , isReflCo rhs_co
-  = return (setCtEvPredType old_ev new_pred)
-
-  | CtGiven { ctev_evar = old_evar } <- old_ev
-  = do { let new_tm = evCoercion ( mkSymCo lhs_co
-                                  `mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar)
-                                  `mkTransCo` rhs_co)
-       ; newGivenEvVar loc (new_pred, new_tm) }
-
-  | CtWanted { ctev_dest = dest
-             , ctev_rewriters = rewriters } <- old_ev
-  , let rewriters' = rewriters S.<> new_rewriters
-  = do { (new_ev, hole_co) <- newWantedEq loc rewriters'
-                                          (ctEvRole old_ev) nlhs nrhs
-       ; let co = maybeSymCo swapped $
-                  lhs_co
-                  `mkTransCo` hole_co
-                  `mkTransCo` mkSymCo rhs_co
-       ; setWantedEq dest co
-       ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev
-                                            , ppr nlhs
-                                            , ppr nrhs
-                                            , ppr co
-                                            , ppr new_rewriters ])
-       ; return new_ev }
-
-#if __GLASGOW_HASKELL__ <= 810
-  | otherwise
-  = panic "rewriteEvidence"
-#endif
-  where
-    new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs
-    loc      = ctEvLoc old_ev
-
-{-
-************************************************************************
-*                                                                      *
-              Unification
-*                                                                      *
-************************************************************************
-
-Note [unifyWanted]
-~~~~~~~~~~~~~~~~~~
-When decomposing equalities we often create new wanted constraints for
-(s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.
-
-Rather than making an equality test (which traverses the structure of the
-type, perhaps fruitlessly), unifyWanted traverses the common structure, and
-bales out when it finds a difference by creating a new Wanted constraint.
-But where it succeeds in finding common structure, it just builds a coercion
-to reflect it.
--}
-
-unifyWanted :: RewriterSet -> CtLoc
-            -> Role -> TcType -> TcType -> TcS Coercion
--- Return coercion witnessing the equality of the two types,
--- emitting new work equalities where necessary to achieve that
--- Very good short-cut when the two types are equal, or nearly so
--- See Note [unifyWanted]
--- The returned coercion's role matches the input parameter
-unifyWanted rewriters loc Phantom ty1 ty2
-  = do { kind_co <- unifyWanted rewriters loc Nominal (typeKind ty1) (typeKind ty2)
-       ; return (mkPhantomCo kind_co ty1 ty2) }
-
-unifyWanted rewriters loc role orig_ty1 orig_ty2
-  = go orig_ty1 orig_ty2
-  where
-    go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2
-    go ty1 ty2 | Just ty2' <- coreView ty2 = go ty1 ty2'
-
-    go (FunTy af1 w1 s1 t1) (FunTy af2 w2 s2 t2)
-      | af1 == af2    -- Important!  See #21530
-      = do { co_s <- unifyWanted rewriters loc role s1 s2
-           ; co_t <- unifyWanted rewriters loc role t1 t2
-           ; co_w <- unifyWanted rewriters loc Nominal w1 w2
-           ; return (mkNakedFunCo1 role af1 co_w co_s co_t) }
-
-    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
-      | tc1 == tc2, tys1 `equalLength` tys2
-      , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality
-      = do { cos <- zipWith3M (unifyWanted rewriters loc)
-                              (tyConRoleListX role tc1) tys1 tys2
-           ; return (mkTyConAppCo role tc1 cos) }
-
-    go ty1@(TyVarTy tv) ty2
-      = do { mb_ty <- isFilledMetaTyVar_maybe tv
-           ; case mb_ty of
-                Just ty1' -> go ty1' ty2
-                Nothing   -> bale_out ty1 ty2}
-    go ty1 ty2@(TyVarTy tv)
-      = do { mb_ty <- isFilledMetaTyVar_maybe tv
-           ; case mb_ty of
-                Just ty2' -> go ty1 ty2'
-                Nothing   -> bale_out ty1 ty2 }
-
-    go ty1@(CoercionTy {}) (CoercionTy {})
-      = return (mkReflCo role ty1) -- we just don't care about coercions!
-
-    go ty1 ty2 = bale_out ty1 ty2
-
-    bale_out ty1 ty2
-       | ty1 `tcEqType` ty2 = return (mkReflCo role ty1)
-        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)
-       | otherwise = emitNewWantedEq loc rewriters role orig_ty1 orig_ty2
-
-
-{-
-Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we decompose a dependent tycon we obtain a list of
-mixed wanted type and kind equalities. Ideally we want
-all the kind equalities to get solved first so that we avoid
-generating duplicate kind equalities
-
-For example, consider decomposing a TyCon equality
-
-    (0) [W] T k_fresh (t1::k_fresh) ~ T k1 (t2::k_fresh)
-
-This gives rise to 2 equalities in the solver worklist
-
-    (1) [W] k_fresh ~ k1
-    (2) [W] t1::k_fresh ~ t2::k1
-
-The solver worklist is processed in LIFO order:
-see GHC.Tc.Solver.InertSet.selectWorkItem.
-i.e. (2) is processed _before_ (1). Now, while solving (2)
-we would call `canEqCanLHSHetero` and that would emit a
-wanted kind equality
-
-    (3) [W] k_fresh ~ k1
-
-But (3) is exactly the same as (1)!
-
-To avoid such duplicate wanted constraints from being added to the worklist,
-we ensure that (2) is processed before (1). Since we are processing
-the worklist in a LIFO ordering, we do it by emitting (1) before (2).
-This is exactly what we do in `unifyWanteds`.
-
-NB: This ordering is not needed when we decompose FunTyCons as they are not dependently typed
--}
-
--- NB: Length of [CtLoc] and [Roles] may be infinite
--- but list of RHS [TcType] and LHS [TcType] is finite and both are of equal length
-unifyWanteds :: RewriterSet -> [CtLoc] -> [Role]
-             -> [TcType] -- List of RHS types
-             -> [TcType] -- List of LHS types
-             -> TcS [Coercion]
-unifyWanteds rewriters ctlocs roles rhss lhss = unify_wanteds rewriters $ zip4 ctlocs roles rhss lhss
-  where
-    -- Order is important here
-    -- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
-    unify_wanteds _ [] = return []
-    unify_wanteds rewriters ((new_loc, tc_role, ty1, ty2) : rest)
-       = do { cos <- unify_wanteds rewriters rest
-            ; co  <- unifyWanted rewriters new_loc tc_role ty1 ty2
-            ; return (co:cos) }
diff --git a/compiler/GHC/Tc/Solver/Dict.hs b/compiler/GHC/Tc/Solver/Dict.hs
new file mode 100644
index 0000000000..75635a4c89
--- /dev/null
+++ b/compiler/GHC/Tc/Solver/Dict.hs
@@ -0,0 +1,859 @@
+-- | Solving Class constraints CDictCan
+module GHC.Tc.Solver.Dict (
+  doTopReactDict,
+  checkInstanceOK,
+  matchLocalInst, chooseInstance
+
+  ) where
+
+import GHC.Prelude
+
+import GHC.Tc.Errors.Types
+import GHC.Tc.Utils.TcType
+import GHC.Tc.Instance.FunDeps
+import GHC.Tc.Types.Evidence
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Types.Origin
+import GHC.Tc.Solver.InertSet
+import GHC.Tc.Solver.Monad
+
+import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey )
+
+import GHC.Core.Type as Type
+import GHC.Core.InstEnv     ( DFunInstType, Coherence(..) )
+import GHC.Core.Class
+import GHC.Core.Predicate
+import GHC.Core.Unify ( ruleMatchTyKiX )
+
+import GHC.Types.Var
+import GHC.Types.Var.Set
+import GHC.Types.SrcLoc
+import GHC.Types.Var.Env
+import GHC.Types.Unique( hasKey )
+
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Misc
+
+import GHC.Driver.Session
+
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.Maybe ( listToMaybe, mapMaybe )
+
+
+{- *******************************************************************
+*                                                                    *
+         Top-level reaction for class constraints (CDictCan)
+*                                                                    *
+**********************************************************************-}
+
+doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct)
+-- Try to use type-class instance declarations to simplify the constraint
+doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls
+                                          , cc_tyargs = xis })
+  | isGiven ev   -- Never use instances for Given constraints
+  = continueWith work_item
+     -- See Note [No Given/Given fundeps]
+
+  | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis   -- Cached
+  = do { setEvBindIfWanted ev IsCoherent (ctEvTerm solved_ev)
+       ; stopWith ev "Dict/Top (cached)" }
+
+  | otherwise  -- Wanted, but not cached
+   = do { dflags <- getDynFlags
+        ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc
+        ; case lkup_res of
+               OneInst { cir_what = what }
+                  -> do { insertSafeOverlapFailureTcS what work_item
+                        ; addSolvedDict what ev cls xis
+                        ; chooseInstance work_item lkup_res }
+               _  -> -- NoInstance or NotSure
+                     -- We didn't solve it; so try functional dependencies with
+                     -- the instance environment
+                     do { doTopFundepImprovement work_item
+                        ; tryLastResortProhibitedSuperclass inerts work_item } }
+   where
+     dict_loc = ctEvLoc ev
+
+
+doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)
+
+-- | As a last resort, we TEMPORARILY allow a prohibited superclass solve,
+-- emitting a loud warning when doing so: we might be creating non-terminating
+-- evidence (as we are in T22912 for example).
+--
+-- See Note [Migrating away from loopy superclass solving] in GHC.Tc.TyCl.Instance.
+tryLastResortProhibitedSuperclass :: InertSet -> Ct -> TcS (StopOrContinue Ct)
+tryLastResortProhibitedSuperclass inerts
+    work_item@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = xis })
+  | let loc_w  = ctEvLoc ev_w
+        orig_w = ctLocOrigin loc_w
+  , ScOrigin _ NakedSc <- orig_w   -- work_item is definitely Wanted
+  , Just ct_i <- lookupInertDict (inert_cans inerts) loc_w cls xis
+  , let ev_i = ctEvidence ct_i
+  , isGiven ev_i
+  = do { setEvBindIfWanted ev_w IsCoherent (ctEvTerm ev_i)
+       ; ctLocWarnTcS loc_w $
+         TcRnLoopySuperclassSolve loc_w (ctPred work_item)
+       ; return $ Stop ev_w (text "Loopy superclass") }
+tryLastResortProhibitedSuperclass _ work_item
+  = continueWith work_item
+
+chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct)
+chooseInstance work_item
+               (OneInst { cir_new_theta   = theta
+                        , cir_what        = what
+                        , cir_mk_ev       = mk_ev
+                        , cir_coherence   = coherence })
+  = do { traceTcS "doTopReact/found instance for" $ ppr ev
+       ; deeper_loc <- checkInstanceOK loc what pred
+       ; checkReductionDepth deeper_loc pred
+       ; evb <- getTcEvBindsVar
+       ; if isCoEvBindsVar evb
+         then continueWith work_item
+                  -- See Note [Instances in no-evidence implications]
+         else
+           do { evc_vars <- mapM (newWanted deeper_loc (ctRewriters work_item)) theta
+              ; setEvBindIfWanted ev coherence (mk_ev (map getEvExpr evc_vars))
+              ; emitWorkNC (freshGoals evc_vars)
+              ; stopWith ev "Dict/Top (solved wanted)" }}
+  where
+     ev         = ctEvidence work_item
+     pred       = ctEvPred ev
+     loc        = ctEvLoc ev
+
+chooseInstance work_item lookup_res
+  = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)
+
+checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
+-- Check that it's OK to use this instance:
+--    (a) the use is well staged in the Template Haskell sense
+-- Returns the CtLoc to used for sub-goals
+-- Probably also want to call checkReductionDepth
+checkInstanceOK loc what pred
+  = do { checkWellStagedDFun loc what pred
+       ; return deeper_loc }
+  where
+     deeper_loc = zap_origin (bumpCtLocDepth loc)
+     origin     = ctLocOrigin loc
+
+     zap_origin loc  -- After applying an instance we can set ScOrigin to
+                     -- NotNakedSc, so that prohibitedSuperClassSolve never fires
+                     -- See Note [Solving superclass constraints] in
+                     -- GHC.Tc.TyCl.Instance, (sc1).
+       | ScOrigin what _ <- origin
+       = setCtLocOrigin loc (ScOrigin what NotNakedSc)
+       | otherwise
+       = loc
+
+{- Note [Instances in no-evidence implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In #15290 we had
+  [G] forall p q. Coercible p q => Coercible (m p) (m q))
+  [W] forall <no-ev> a. m (Int, IntStateT m a)
+                          ~R#
+                        m (Int, StateT Int m a)
+
+The Given is an ordinary quantified constraint; the Wanted is an implication
+equality that arises from
+  [W] (forall a. t1) ~R# (forall a. t2)
+
+But because the (t1 ~R# t2) is solved "inside a type" (under that forall a)
+we can't generate any term evidence.  So we can't actually use that
+lovely quantified constraint.  Alas!
+
+This test arranges to ignore the instance-based solution under these
+(rare) circumstances.   It's sad, but I  really don't see what else we can do.
+-}
+
+
+matchClassInst :: DynFlags -> InertSet
+               -> Class -> [Type]
+               -> CtLoc -> TcS ClsInstResult
+matchClassInst dflags inerts clas tys loc
+-- First check whether there is an in-scope Given that could
+-- match this constraint.  In that case, do not use any instance
+-- whether top level, or local quantified constraints.
+-- See Note [Instance and Given overlap]
+  | not (xopt LangExt.IncoherentInstances dflags)
+  , not (naturallyCoherentClass clas)
+  , not (noMatchableGivenDicts inerts loc clas tys)
+  = do { traceTcS "Delaying instance application" $
+           vcat [ text "Work item=" <+> pprClassPred clas tys ]
+       ; return NotSure }
+
+  | otherwise
+  = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{'
+       ; local_res <- matchLocalInst pred loc
+       ; case local_res of
+           OneInst {} ->  -- See Note [Local instances and incoherence]
+                do { traceTcS "} matchClassInst local match" $ ppr local_res
+                   ; return local_res }
+
+           NotSure -> -- In the NotSure case for local instances
+                      -- we don't want to try global instances
+                do { traceTcS "} matchClassInst local not sure" empty
+                   ; return local_res }
+
+           NoInstance  -- No local instances, so try global ones
+              -> do { global_res <- matchGlobalInst dflags False clas tys
+                    ; traceTcS "} matchClassInst global result" $ ppr global_res
+                    ; return global_res } }
+  where
+    pred = mkClassPred clas tys
+
+-- | If a class is "naturally coherent", then we needn't worry at all, in any
+-- way, about overlapping/incoherent instances. Just solve the thing!
+-- See Note [Naturally coherent classes]
+-- See also Note [The equality types story] in GHC.Builtin.Types.Prim.
+naturallyCoherentClass :: Class -> Bool
+naturallyCoherentClass cls
+  = isCTupleClass cls
+    || cls `hasKey` heqTyConKey
+    || cls `hasKey` eqTyConKey
+    || cls `hasKey` coercibleTyConKey
+
+
+{- Note [Instance and Given overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Example, from the OutsideIn(X) paper:
+       instance P x => Q [x]
+       instance (x ~ y) => R y [x]
+
+       wob :: forall a b. (Q [b], R b a) => a -> Int
+
+       g :: forall a. Q [a] => [a] -> Int
+       g x = wob x
+
+From 'g' we get the implication constraint:
+            forall a. Q [a] => (Q [beta], R beta [a])
+If we react (Q [beta]) with its top-level axiom, we end up with a
+(P beta), which we have no way of discharging. On the other hand,
+if we react R beta [a] with the top-level we get  (beta ~ a), which
+is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is
+now solvable by the given Q [a].
+
+The partial solution is that:
+  In matchClassInst (and thus in topReact), we return a matching
+  instance only when there is no Given in the inerts which is
+  unifiable to this particular dictionary.
+
+  We treat any meta-tyvar as "unifiable" for this purpose,
+  *including* untouchable ones.  But not skolems like 'a' in
+  the implication constraint above.
+
+The end effect is that, much as we do for overlapping instances, we
+delay choosing a class instance if there is a possibility of another
+instance OR a given to match our constraint later on. This fixes
+tickets #4981 and #5002.
+
+Other notes:
+
+* The check is done *first*, so that it also covers classes
+  with built-in instance solving, such as
+     - constraint tuples
+     - natural numbers
+     - Typeable
+
+* See also Note [What might equal later?] in GHC.Tc.Solver.InertSet.
+
+* The given-overlap problem is arguably not easy to appear in practice
+  due to our aggressive prioritization of equality solving over other
+  constraints, but it is possible. I've added a test case in
+  typecheck/should-compile/GivenOverlapping.hs
+
+* Another "live" example is #10195; another is #10177.
+
+* We ignore the overlap problem if -XIncoherentInstances is in force:
+  see #6002 for a worked-out example where this makes a
+  difference.
+
+* Moreover notice that our goals here are different than the goals of
+  the top-level overlapping checks. There we are interested in
+  validating the following principle:
+
+      If we inline a function f at a site where the same global
+      instance environment is available as the instance environment at
+      the definition site of f then we should get the same behaviour.
+
+  But for the Given Overlap check our goal is just related to completeness of
+  constraint solving.
+
+* The solution is only a partial one.  Consider the above example with
+       g :: forall a. Q [a] => [a] -> Int
+       g x = let v = wob x
+             in v
+  and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most
+  general type for 'v'.  When generalising v's type we'll simplify its
+  Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we
+  will use the instance declaration after all. #11948 was a case
+  in point.
+
+All of this is disgustingly delicate, so to discourage people from writing
+simplifiable class givens, we warn about signatures that contain them;
+see GHC.Tc.Validity Note [Simplifiable given constraints].
+
+Note [Naturally coherent classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A few built-in classes are "naturally coherent".  This term means that
+the "instance" for the class is bidirectional with its superclass(es).
+For example, consider (~~), which behaves as if it was defined like
+this:
+  class a ~# b => a ~~ b
+  instance a ~# b => a ~~ b
+(See Note [The equality types story] in GHC.Builtin.Types.Prim.)
+
+Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2,
+without worrying about Note [Instance and Given overlap].  Why?  Because
+if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and
+so the reduction of the [W] constraint does not risk losing any solutions.
+
+On the other hand, it can be fatal to /fail/ to reduce such
+equalities, on the grounds of Note [Instance and Given overlap],
+because many good things flow from [W] t1 ~# t2.
+
+The same reasoning applies to
+
+* (~~)        heqTyCon
+* (~)         eqTyCon
+* Coercible   coercibleTyCon
+
+And less obviously to:
+
+* Tuple classes.  For reasons described in GHC.Tc.Solver.Types
+  Note [Tuples hiding implicit parameters], we may have a constraint
+     [W] (?x::Int, C a)
+  with an exactly-matching Given constraint.  We must decompose this
+  tuple and solve the components separately, otherwise we won't solve
+  it at all!  It is perfectly safe to decompose it, because again the
+  superclasses invert the instance;  e.g.
+      class (c1, c2) => (% c1, c2 %)
+      instance (c1, c2) => (% c1, c2 %)
+  Example in #14218
+
+Examples: T5853, T10432, T5315, T9222, T2627b, T3028b
+
+PS: the term "naturally coherent" doesn't really seem helpful.
+Perhaps "invertible" or something?  I left it for now though.
+
+Note [Local instances and incoherence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f :: forall b c. (Eq b, forall a. Eq a => Eq (c a))
+                 => c b -> Bool
+   f x = x==x
+
+We get [W] Eq (c b), and we must use the local instance to solve it.
+
+BUT that wanted also unifies with the top-level Eq [a] instance,
+and Eq (Maybe a) etc.  We want the local instance to "win", otherwise
+we can't solve the wanted at all.  So we mark it as Incohherent.
+According to Note [Rules for instance lookup] in GHC.Core.InstEnv, that'll
+make it win even if there are other instances that unify.
+
+Moreover this is not a hack!  The evidence for this local instance
+will be constructed by GHC at a call site... from the very instances
+that unify with it here.  It is not like an incoherent user-written
+instance which might have utterly different behaviour.
+
+Consider  f :: Eq a => blah.  If we have [W] Eq a, we certainly
+get it from the Eq a context, without worrying that there are
+lots of top-level instances that unify with [W] Eq a!  We'll use
+those instances to build evidence to pass to f. That's just the
+nullary case of what's happening here.
+-}
+
+matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult
+-- Look up the predicate in Given quantified constraints,
+-- which are effectively just local instance declarations.
+matchLocalInst pred loc
+  = do { inerts@(IS { inert_cans = ics }) <- getTcSInerts
+       ; case match_local_inst inerts (inert_insts ics) of
+          { ([], []) -> do { traceTcS "No local instance for" (ppr pred)
+                           ; return NoInstance }
+          ; (matches, unifs) ->
+    do { matches <- mapM mk_instDFun matches
+       ; unifs   <- mapM mk_instDFun unifs
+         -- See Note [Use only the best matching quantified constraint]
+       ; case dominatingMatch matches of
+          { Just (dfun_id, tys, theta)
+            | all ((theta `impliedBySCs`) . thdOf3) unifs
+            ->
+            do { let result = OneInst { cir_new_theta   = theta
+                                      , cir_mk_ev       = evDFunApp dfun_id tys
+                                      , cir_coherence   = IsCoherent
+                                      , cir_what        = LocalInstance }
+               ; traceTcS "Best local instance found:" $
+                  vcat [ text "pred:" <+> ppr pred
+                       , text "result:" <+> ppr result
+                       , text "matches:" <+> ppr matches
+                       , text "unifs:" <+> ppr unifs ]
+               ; return result }
+
+          ; mb_best ->
+            do { traceTcS "Multiple local instances; not committing to any"
+                  $ vcat [ text "pred:" <+> ppr pred
+                         , text "matches:" <+> ppr matches
+                         , text "unifs:" <+> ppr unifs
+                         , text "best_match:" <+> ppr mb_best ]
+               ; return NotSure }}}}}
+  where
+    pred_tv_set = tyCoVarsOfType pred
+
+    mk_instDFun :: (CtEvidence, [DFunInstType]) -> TcS InstDFun
+    mk_instDFun (ev, tys) =
+      let dfun_id = ctEvEvId ev
+      in do { (tys, theta) <- instDFunType (ctEvEvId ev) tys
+            ; return (dfun_id, tys, theta) }
+
+    -- Compute matching and unifying local instances
+    match_local_inst :: InertSet
+                     -> [QCInst]
+                     -> ( [(CtEvidence, [DFunInstType])]
+                        , [(CtEvidence, [DFunInstType])] )
+    match_local_inst _inerts []
+      = ([], [])
+    match_local_inst inerts (qci@(QCI { qci_tvs  = qtvs
+                                      , qci_pred = qpred
+                                      , qci_ev   = qev })
+                            :qcis)
+      | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set)
+      , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope)
+                                        emptyTvSubstEnv qpred pred
+      , let match = (qev, map (lookupVarEnv tv_subst) qtvs)
+      = (match:matches, unifs)
+
+      | otherwise
+      = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred))
+                  (ppr qci $$ ppr pred)
+            -- ASSERT: unification relies on the
+            -- quantified variables being fresh
+        (matches, this_unif `combine` unifs)
+      where
+        qloc = ctEvLoc qev
+        qtv_set = mkVarSet qtvs
+        (matches, unifs) = match_local_inst inerts qcis
+        this_unif
+          | Just subst <- mightEqualLater inerts qpred qloc pred loc
+          = Just (qev, map  (lookupTyVar subst) qtvs)
+          | otherwise
+          = Nothing
+
+        combine Nothing  us = us
+        combine (Just u) us = u : us
+
+-- | Instance dictionary function and type.
+type InstDFun = (DFunId, [TcType], TcThetaType)
+
+-- | Try to find a local quantified instance that dominates all others,
+-- i.e. which has a weaker instance context than all the others.
+--
+-- See Note [Use only the best matching quantified constraint].
+dominatingMatch :: [InstDFun] -> Maybe InstDFun
+dominatingMatch matches =
+  listToMaybe $ mapMaybe (uncurry go) (holes matches)
+  -- listToMaybe: arbitrarily pick any one context that is weaker than
+  -- all others, e.g. so that we can handle [Eq a, Num a] vs [Num a, Eq a]
+  -- (see test case T22223).
+
+  where
+    go :: InstDFun -> [InstDFun] -> Maybe InstDFun
+    go this [] = Just this
+    go this@(_,_,this_theta) ((_,_,other_theta):others)
+      | this_theta `impliedBySCs` other_theta
+      = go this others
+      | otherwise
+      = Nothing
+
+-- | Whether a collection of constraints is implied by another collection,
+-- according to a simple superclass check.
+--
+-- See Note [When does a quantified instance dominate another?].
+impliedBySCs :: TcThetaType -> TcThetaType -> Bool
+impliedBySCs c1 c2 = all in_c2 c1
+  where
+    in_c2 :: TcPredType -> Bool
+    in_c2 pred = any (pred `tcEqType`) c2_expanded
+
+    c2_expanded :: [TcPredType]  -- Includes all superclasses
+    c2_expanded = [ q | p <- c2, q <- p : transSuperClasses p ]
+
+
+{- Note [When does a quantified instance dominate another?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When matching local quantified instances, it's useful to be able to pick
+the one with the weakest precondition, e.g. if one has both
+
+  [G] d1: forall a b. ( Eq a, Num b, C a b  ) => D a b
+  [G] d2: forall a  .                C a Int  => D a Int
+  [W] {w}: D a Int
+
+Then it makes sense to use d2 to solve w, as doing so we end up with a strictly
+weaker proof obligation of `C a Int`, compared to `(Eq a, Num Int, C a Int)`
+were we to use d1.
+
+In theory, to compute whether one context implies another, we would need to
+recursively invoke the constraint solver. This is expensive, so we instead do
+a simple check using superclasses, implemented in impliedBySCs.
+
+Examples:
+
+ - [Eq a] is implied by [Ord a]
+ - [Ord a] is not implied by [Eq a],
+ - any context is implied by itself,
+ - the empty context is implied by any context.
+
+Note [Use only the best matching quantified constraint]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#20582) the ambiguity check for
+  (forall a. Ord (m a), forall a. Semigroup a => Eq (m a)) => m Int
+
+Because of eager expansion of given superclasses, we get
+  [G] d1: forall a. Ord (m a)
+  [G] d2: forall a. Eq (m a)
+  [G] d3: forall a. Semigroup a => Eq (m a)
+
+  [W] {w1}: forall a. Ord (m a)
+  [W] {w2}: forall a. Semigroup a => Eq (m a)
+
+The first wanted is solved straightforwardly. But the second wanted
+matches *two* local instances: d2 and d3. Our general rule around multiple local
+instances is that we refuse to commit to any of them. However, that
+means that our type fails the ambiguity check. That's bad: the type
+is perfectly fine. (This actually came up in the wild, in the streamly
+library.)
+
+The solution is to prefer local instances which are easier to prove, meaning
+that they have a weaker precondition. In this case, the empty context
+of d2 is a weaker constraint than the "Semigroup a" context of d3, so we prefer
+using it when proving w2. This allows us to pass the ambiguity check here.
+
+Our criterion for solving a Wanted by matching local quantified instances is
+thus as follows:
+
+  - There is a matching local quantified instance that dominates all others
+    matches, in the sense of [When does a quantified instance dominate another?].
+    Any such match do, we pick it arbitrarily (the T22223 example below says why).
+  - This local quantified instance also dominates all the unifiers, as we
+    wouldn't want to commit to a single match when we might have multiple,
+    genuinely different matches after further unification takes place.
+
+Some other examples:
+
+
+  #15244:
+
+    f :: (C g, D g) => ....
+    class S g => C g where ...
+    class S g => D g where ...
+    class (forall a. Eq a => Eq (g a)) => S g where ...
+
+  Here, in f's RHS, there are two identical quantified constraints
+  available, one via the superclasses of C and one via the superclasses
+  of D. Given that each implies the other, we pick one arbitrarily.
+
+
+  #22216:
+
+    class Eq a
+    class Eq a => Ord a
+    class (forall b. Eq b => Eq (f b)) => Eq1 f
+    class (Eq1 f, forall b. Ord b => Ord (f b)) => Ord1 f
+
+  Suppose we have
+
+    [G] d1: Ord1 f
+    [G] d2: Eq a
+    [W] {w}: Eq (f a)
+
+  Superclass expansion of d1 gives us:
+
+    [G] d3 : Eq1 f
+    [G] d4 : forall b. Ord b => Ord (f b)
+
+  expanding d4 and d5 gives us, respectively:
+
+    [G] d5 : forall b. Eq  b => Eq (f b)
+    [G] d6 : forall b. Ord b => Eq (f b)
+
+  Now we have two matching local instances that we could use when solving the
+  Wanted. However, it's obviously silly to use d6, given that d5 provides us with
+  as much information, with a strictly weaker precondition. So we pick d5 to solve
+  w. If we chose d6, we would get [W] Ord a, which in this case we can't solve.
+
+
+  #22223:
+
+    [G] forall a b. (Eq a, Ord b) => C a b
+    [G] forall a b. (Ord b, Eq a) => C a b
+    [W] C x y
+
+  Here we should be free to pick either quantified constraint, as they are
+  equivalent up to re-ordering of the constraints in the context.
+  See also Note [Do not add duplicate quantified instances]
+  in GHC.Tc.Solver.Monad.
+
+Test cases:
+  typecheck/should_compile/T20582
+  quantified-constraints/T15244
+  quantified-constraints/T22216{a,b,c,d,e}
+  quantified-constraints/T22223
+
+Historical note: a previous solution was to instead pick the local instance
+with the least superclass depth (see Note [Replacement vs keeping]),
+but that doesn't work for the example from #22216.
+
+
+************************************************************************
+*                                                                      *
+*          Functional dependencies, instantiation of equations
+*                                                                      *
+************************************************************************
+
+When we spot an equality arising from a functional dependency,
+we now use that equality (a "wanted") to rewrite the work-item
+constraint right away.  This avoids two dangers
+
+ Danger 1: If we send the original constraint on down the pipeline
+           it may react with an instance declaration, and in delicate
+           situations (when a Given overlaps with an instance) that
+           may produce new insoluble goals: see #4952
+
+ Danger 2: If we don't rewrite the constraint, it may re-react
+           with the same thing later, and produce the same equality
+           again --> termination worries.
+
+To achieve this required some refactoring of GHC.Tc.Instance.FunDeps (nicer
+now!).
+
+Note [FunDep and implicit parameter reactions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Currently, our story of interacting two dictionaries (or a dictionary
+and top-level instances) for functional dependencies, and implicit
+parameters, is that we simply produce new Wanted equalities.  So for example
+
+        class D a b | a -> b where ...
+    Inert:
+        d1 :g D Int Bool
+    WorkItem:
+        d2 :w D Int alpha
+
+    We generate the extra work item
+        cv :w alpha ~ Bool
+    where 'cv' is currently unused.  However, this new item can perhaps be
+    spontaneously solved to become given and react with d2,
+    discharging it in favour of a new constraint d2' thus:
+        d2' :w D Int Bool
+        d2 := d2' |> D Int cv
+    Now d2' can be discharged from d1
+
+We could be more aggressive and try to *immediately* solve the dictionary
+using those extra equalities.
+
+If that were the case with the same inert set and work item we might discard
+d2 directly:
+
+        cv :w alpha ~ Bool
+        d2 := d1 |> D Int cv
+
+But in general it's a bit painful to figure out the necessary coercion,
+so we just take the first approach. Here is a better example. Consider:
+    class C a b c | a -> b
+And:
+     [Given]  d1 : C T Int Char
+     [Wanted] d2 : C T beta Int
+In this case, it's *not even possible* to solve the wanted immediately.
+So we should simply output the functional dependency and add this guy
+[but NOT its superclasses] back in the worklist. Even worse:
+     [Given] d1 : C T Int beta
+     [Wanted] d2: C T beta Int
+Then it is solvable, but its very hard to detect this on the spot.
+
+It's exactly the same with implicit parameters, except that the
+"aggressive" approach would be much easier to implement.
+
+Note [Fundeps with instances, and equality orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This Note describes a delicate interaction that constrains the orientation of
+equalities. This one is about fundeps, but the /exact/ same thing arises for
+type-family injectivity constraints: see Note [Improvement orientation].
+
+doTopFundepImprovement compares the constraint with all the instance
+declarations, to see if we can produce any equalities. E.g
+   class C2 a b | a -> b
+   instance C Int Bool
+Then the constraint (C Int ty) generates the equality [W] ty ~ Bool.
+
+There is a nasty corner in #19415 which led to the typechecker looping:
+   class C s t b | s -> t
+   instance ... => C (T kx x) (T ky y) Int
+   T :: forall k. k -> Type
+
+   work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char
+      where kb0, b0 are unification vars
+
+   ==> {doTopFundepImprovement: compare work_item with instance,
+        generate /fresh/ unification variables kfresh0, yfresh0,
+        emit a new Wanted, and add dwrk to inert set}
+
+   Suppose we emit this new Wanted from the fundep:
+       [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0)
+
+   ==> {solve that equality kb0 := kfresh0, b0 := yfresh0}
+   Now kick out dwrk, since it mentions kb0
+   But now we are back to the start!  Loop!
+
+NB1: This example relies on an instance that does not satisfy the
+     coverage condition (although it may satisfy the weak coverage
+     condition), and hence whose fundeps generate fresh unification
+     variables.  Not satisfying the coverage condition is known to
+     lead to termination trouble, but in this case it's plain silly.
+
+NB2: In this example, the third parameter to C ensures that the
+     instance doesn't actually match the Wanted, so we can't use it to
+     solve the Wanted
+
+We solve the problem by (#21703):
+
+    carefully orienting the new Wanted so that all the
+    freshly-generated unification variables are on the LHS.
+
+    Thus we emit
+       [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0)
+    and /NOT/
+       [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0)
+
+Now we'll unify kfresh0:=kb0, yfresh0:=b0, and all is well.  The general idea
+is that we want to preferentially eliminate those freshly-generated
+unification variables, rather than unifying older variables, which causes
+kick-out etc.
+
+Keeping younger variables on the left also gives very minor improvement in
+the compiler performance by having less kick-outs and allocations (-0.1% on
+average).  Indeed Historical Note [Eliminate younger unification variables]
+in GHC.Tc.Utils.Unify describes an earlier attempt to do so systematically,
+apparently now in abeyance.
+
+But this is is a delicate solution. We must take care to /preserve/
+orientation during solving. Wrinkles:
+
+(W1) We start with
+       [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0)
+     Decompose to
+       [W] kfresh0 ~ kb0
+       [W] (yfresh0::kfresh0) ~ (b0::kb0)
+     Preserve orientiation when decomposing!!
+
+(W2) Suppose we happen to tackle the second Wanted from (W1)
+     first. Then in canEqCanLHSHetero we emit a /kind/ equality, as
+     well as a now-homogeneous type equality
+       [W] kco : kfresh0 ~ kb0
+       [W] (yfresh0::kfresh0) ~ (b0::kb0) |> (sym kco)
+     Preserve orientation in canEqCanLHSHetero!!  (Failing to
+     preserve orientation here was the immediate cause of #21703.)
+
+(W3) There is a potential interaction with the swapping done by
+     GHC.Tc.Utils.Unify.swapOverTyVars.  We think it's fine, but it's
+     a slight worry.  See especially Note [TyVar/TyVar orientation] in
+     that module.
+
+The trouble is that "preserving orientation" is a rather global invariant,
+and sometimes we definitely do want to swap (e.g. Int ~ alpha), so we don't
+even have a precise statement of what the invariant is.  The advantage
+of the preserve-orientation plan is that it is extremely cheap to implement,
+and apparently works beautifully.
+
+--- Alternative plan (1) ---
+Rather than have an ill-defined invariant, another possiblity is to
+elminate those fresh unification variables at birth, when generating
+the new fundep-inspired equalities.
+
+The key idea is to call `instFlexiX` in `emitFunDepWanteds` on only those
+type variables that are guaranteed to give us some progress. This means we
+have to locally (without calling emitWanteds) identify the type variables
+that do not give us any progress.  In the above example, we _know_ that
+emitting the two wanteds `kco` and `co` is fruitless.
+
+  Q: How do we identify such no-ops?
+
+  1. Generate a matching substitution from LHS to RHS
+        ɸ = [kb0 :-> k0, b0 :->  y0]
+  2. Call `instFlexiX` on only those type variables that do not appear in the domain of ɸ
+        ɸ' = instFlexiX ɸ (tvs - domain ɸ)
+  3. Apply ɸ' on LHS and then call emitWanteds
+        unifyWanteds ... (subst ɸ' LHS) RHS
+
+Why will this work?  The matching substitution ɸ will be a best effort
+substitution that gives us all the easy solutions. It can be generated with
+modified version of `Core/Unify.unify_tys` where we run it in a matching mode
+and never generate `SurelyApart` and always return a `MaybeApart Subst`
+instead.
+
+The same alternative plan would work for type-family injectivity constraints:
+see Note [Improvement orientation].
+--- End of Alternative plan (1) ---
+
+--- Alternative plan (2) ---
+We could have a new flavour of TcTyVar (like `TauTv`, `TyVarTv` etc; see GHC.Tc.Utils.TcType.MetaInfo)
+for the fresh unification variables introduced by functional dependencies.  Say `FunDepTv`.  Then in
+GHC.Tc.Utils.Unify.swapOverTyVars we could arrange to keep a `FunDepTv` on the left if possible.
+Looks possible, but it's one more complication.
+--- End of Alternative plan (2) ---
+
+
+--- Historical note: Failed Alternative Plan (3) ---
+Previously we used a flag `cc_fundeps` in `CDictCan`. It would flip to False
+once we used a fun dep to hint the solver to break and to stop emitting more
+wanteds.  This solution was not complete, and caused a failures while trying
+to solve for transitive functional dependencies (test case: T21703)
+-- End of Historical note: Failed Alternative Plan (3) --
+
+Note [Weird fundeps]
+~~~~~~~~~~~~~~~~~~~~
+Consider   class Het a b | a -> b where
+              het :: m (f c) -> a -> m b
+
+           class GHet (a :: * -> *) (b :: * -> *) | a -> b
+           instance            GHet (K a) (K [a])
+           instance Het a b => GHet (K a) (K b)
+
+The two instances don't actually conflict on their fundeps,
+although it's pretty strange.  So they are both accepted. Now
+try   [W] GHet (K Int) (K Bool)
+This triggers fundeps from both instance decls;
+      [W] K Bool ~ K [a]
+      [W] K Bool ~ K beta
+And there's a risk of complaining about Bool ~ [a].  But in fact
+the Wanted matches the second instance, so we never get as far
+as the fundeps.
+
+#7875 is a case in point.
+-}
+
+doTopFundepImprovement :: Ct -> TcS ()
+-- Try to functional-dependency improvement between the constraint
+-- and the top-level instance declarations
+-- See Note [Fundeps with instances, and equality orientation]
+-- See also Note [Weird fundeps]
+doTopFundepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls
+                                           , cc_tyargs = xis })
+  = do { traceTcS "try_fundeps" (ppr work_item)
+       ; instEnvs <- getInstEnvs
+       ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis
+       ; emitFunDepWanteds (ctEvRewriters ev) fundep_eqns }
+  where
+     dict_pred   = mkClassPred cls xis
+     dict_loc    = ctEvLoc ev
+     dict_origin = ctLocOrigin dict_loc
+
+     mk_ct_loc :: PredType   -- From instance decl
+               -> SrcSpan    -- also from instance deol
+               -> (CtLoc, RewriterSet)
+     mk_ct_loc inst_pred inst_loc
+       = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin
+                                                 inst_pred inst_loc }
+         , emptyRewriterSet )
+
+doTopFundepImprovement work_item = pprPanic "doTopFundepImprovement" (ppr work_item)
+
diff --git a/compiler/GHC/Tc/Solver/Equality.hs b/compiler/GHC/Tc/Solver/Equality.hs
new file mode 100644
index 0000000000..ef2b5945c2
--- /dev/null
+++ b/compiler/GHC/Tc/Solver/Equality.hs
@@ -0,0 +1,2964 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiWayIf #-}
+
+module GHC.Tc.Solver.Equality(
+     solveCanonicalEquality, solveNonCanonicalEquality
+  ) where
+
+
+import GHC.Prelude
+
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Types.Origin
+import GHC.Tc.Utils.Unify
+import GHC.Tc.Utils.TcType
+import GHC.Tc.Utils.TcMType( promoteMetaTyVarTo )
+import GHC.Tc.Solver.Rewrite
+import GHC.Tc.Solver.Monad
+import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance )
+import GHC.Tc.Solver.InertSet
+import GHC.Tc.Solver.Types( findFunEqsByTyCon )
+import GHC.Tc.Types.Evidence
+import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe )
+import GHC.Tc.Instance.FunDeps( FunDepEqn(..) )
+
+import GHC.Core.Type
+import GHC.Core.Predicate
+import GHC.Core.Class
+import GHC.Core.DataCon ( dataConName )
+import GHC.Core.TyCon
+import GHC.Core.TyCo.Rep   -- cleverly decomposes types, good for completeness checking
+import GHC.Core.Coercion
+import GHC.Core.Coercion.Axiom
+import GHC.Core.Reduction
+import GHC.Core.Unify( tcUnifyTyWithTFs )
+import GHC.Core.InstEnv ( Coherence(..) )
+import GHC.Core.FamInstEnv ( FamInstEnvs, FamInst(..), apartnessCheck
+                           , lookupFamInstEnvByTyCon )
+import GHC.Core
+
+import GHC.Types.Var
+import GHC.Types.Var.Env
+import GHC.Types.Var.Set( anyVarSet )
+import GHC.Types.Name.Reader
+import GHC.Types.Basic
+
+import GHC.Builtin.Types ( anyTypeOfKind )
+
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Misc
+import GHC.Utils.Monad
+import GHC.Utils.Constants( debugIsOn )
+
+import GHC.Data.Pair
+import GHC.Data.Bag
+import Control.Monad
+import Data.Maybe ( isJust, isNothing )
+import Data.List  ( zip4 )
+
+import qualified Data.Semigroup as S
+import Data.Bifunctor ( bimap )
+
+
+{- *********************************************************************
+*                                                                      *
+*        Equalities
+*                                                                      *
+************************************************************************
+
+Note [Canonicalising equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In order to canonicalise an equality, we look at the structure of the
+two types at hand, looking for similarities. A difficulty is that the
+types may look dissimilar before rewriting but similar after rewriting.
+However, we don't just want to jump in and rewrite right away, because
+this might be wasted effort. So, after looking for similarities and failing,
+we rewrite and then try again. Of course, we don't want to loop, so we
+track whether or not we've already rewritten.
+
+It is conceivable to do a better job at tracking whether or not a type
+is rewritten, but this is left as future work. (Mar '15)
+
+Note [Decomposing FunTy]
+~~~~~~~~~~~~~~~~~~~~~~~~
+can_eq_nc' may attempt to decompose a FunTy that is un-zonked.  This
+means that we may very well have a FunTy containing a type of some
+unknown kind. For instance, we may have,
+
+    FunTy (a :: k) Int
+
+Where k is a unification variable. So the calls to splitRuntimeRep_maybe may
+fail (returning Nothing).  In that case we'll fall through, zonk, and try again.
+Zonking should fill the variable k, meaning that decomposition will succeed the
+second time around.
+
+Also note that we require the FunTyFlag to match.  This will stop
+us decomposing
+   (Int -> Bool)  ~  (Show a => blah)
+It's as if we treat (->) and (=>) as different type constructors, which
+indeed they are!
+-}
+
+solveCanonicalEquality :: EqCt -> TcS (StopOrContinue Ct)
+solveCanonicalEquality (EqCt { eq_ev = ev, eq_eq_rel = eq_rel
+                             , eq_lhs = lhs, eq_rhs = rhs })
+  = solveNonCanonicalEquality ev eq_rel (canEqLHSType lhs) rhs
+
+solveNonCanonicalEquality :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)
+solveNonCanonicalEquality ev eq_rel ty1 ty2
+  = do { result <- zonk_eq_types ty1 ty2
+       ; case result of
+           Right ty              -> canEqReflexive ev eq_rel ty
+           Left (Pair ty1' ty2') -> can_eq_nc False ev' eq_rel ty1' ty1' ty2' ty2'
+             where
+               ev' | debugIsOn = setCtEvPredType ev $
+                                 mkPrimEqPredRole (eqRelRole eq_rel) ty1' ty2'
+                   | otherwise = ev
+                   -- ev': satisfy the precondition of can_eq_nc
+       }
+
+can_eq_nc
+   :: Bool            -- True => both types are rewritten
+   -> CtEvidence
+   -> EqRel
+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp
+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp
+   -> TcS (StopOrContinue Ct)
+-- Precondition: in DEBUG mode, the `ctev_pred` of `ev` is (ps_ty1 ~# ps_ty2),
+--               without zonking
+-- This precondition is needed (only in DEBUG) to satisfy the assertions
+--   in mkSelCo, called in canDecomposableTyConAppOK and canDecomposableFunTy
+
+can_eq_nc rewritten ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+  = do { traceTcS "can_eq_nc" $
+         vcat [ ppr rewritten, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ]
+       ; rdr_env <- getGlobalRdrEnvTcS
+       ; fam_insts <- getFamInstEnvs
+       ; can_eq_nc' rewritten rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 }
+
+can_eq_nc'
+   :: Bool           -- True => both input types are rewritten
+   -> GlobalRdrEnv   -- needed to see which newtypes are in scope
+   -> FamInstEnvs    -- needed to unwrap data instances
+   -> CtEvidence
+   -> EqRel
+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp
+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp
+   -> TcS (StopOrContinue Ct)
+
+-- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2
+  | tc1 == tc2
+  = canEqReflexive ev eq_rel ty1
+
+-- Expand synonyms first; see Note [Type synonyms and canonicalization]
+can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+  | Just ty1' <- coreView ty1 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2  ps_ty2
+  | Just ty2' <- coreView ty2 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1  ps_ty1 ty2' ps_ty2
+
+-- need to check for reflexivity in the ReprEq case.
+-- See Note [Eager reflexivity check]
+-- Check only when rewritten because the zonk_eq_types check in canEqNC takes
+-- care of the non-rewritten case.
+can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _
+  | ty1 `tcEqType` ty2
+  = canEqReflexive ev ReprEq ty1
+
+-- When working with ReprEq, unwrap newtypes.
+-- See Note [Unwrap newtypes first]
+-- This must be above the TyVarTy case, in order to guarantee (TyEq:N)
+can_eq_nc' _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+  | ReprEq <- eq_rel
+  , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1
+  = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2
+
+  | ReprEq <- eq_rel
+  , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2
+  = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1
+
+-- Then, get rid of casts
+can_eq_nc' rewritten _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
+  | isNothing (canEqLHS_maybe ty2)  -- See (3) in Note [Equalities with incompatible kinds]
+  = canEqCast rewritten ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2
+can_eq_nc' rewritten _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
+  | isNothing (canEqLHS_maybe ty1)  -- See (3) in Note [Equalities with incompatible kinds]
+  = canEqCast rewritten ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1
+
+----------------------
+-- Otherwise try to decompose
+----------------------
+
+-- Literals
+can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
+ | l1 == l2
+  = do { setEvBindIfWanted ev IsCoherent (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)
+       ; stopWith ev "Equal LitTy" }
+
+-- Decompose FunTy: (s -> t) and (c => t)
+-- NB: don't decompose (Int -> blah) ~ (Show a => blah)
+can_eq_nc' _rewritten _rdr_env _envs ev eq_rel
+           (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1
+           (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2
+  | af1 == af2  -- See Note [Decomposing FunTy]
+  = canDecomposableFunTy ev eq_rel af1 (am1,ty1a,ty1b) (am2,ty2a,ty2b)
+
+-- Decompose type constructor applications
+-- NB: we have expanded type synonyms already
+can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _
+  | Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1
+  , Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2
+   -- we want to catch e.g. Maybe Int ~ (Int -> Int) here for better
+   -- error messages rather than decomposing into AppTys;
+   -- hence no direct match on TyConApp
+  , not (isTypeFamilyTyCon tc1)
+  , not (isTypeFamilyTyCon tc2)
+  = canTyConApp ev eq_rel tc1 tys1 tc2 tys2
+
+can_eq_nc' _rewritten _rdr_env _envs ev eq_rel
+           s1@(ForAllTy (Bndr _ vis1) _) _
+           s2@(ForAllTy (Bndr _ vis2) _) _
+  | vis1 `eqForAllVis` vis2 -- Note [ForAllTy and type equality]
+  = can_eq_nc_forall ev eq_rel s1 s2
+
+-- See Note [Canonicalising type applications] about why we require rewritten types
+-- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families
+-- NB: Only decompose AppTy for nominal equality.
+--     See Note [Decomposing AppTy equalities]
+can_eq_nc' True _rdr_env _envs ev NomEq ty1 _ ty2 _
+  | Just (t1, s1) <- tcSplitAppTy_maybe ty1
+  , Just (t2, s2) <- tcSplitAppTy_maybe ty2
+  = can_eq_app ev t1 s1 t2 s2
+
+-------------------
+-- Can't decompose.
+-------------------
+
+-- No similarity in type structure detected. Rewrite and try again.
+can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
+  = -- Rewrite the two types and try again
+    do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1
+       ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2
+       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
+       ; traceTcS "can_eq_nc: go round again" (ppr new_ev $$ ppr xi1 $$ ppr xi2)
+       ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
+
+----------------------------
+-- Look for a canonical LHS.
+-- Only rewritten types end up below here.
+----------------------------
+
+-- NB: pattern match on True: we want only rewritten types sent to canEqLHS
+-- This means we've rewritten any variables and reduced any type family redexes
+-- See also Note [No top-level newtypes on RHS of representational equalities]
+can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+  | Just can_eq_lhs1 <- canEqLHS_maybe ty1
+  = canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2
+
+  | Just can_eq_lhs2 <- canEqLHS_maybe ty2
+  = canEqCanLHS ev eq_rel IsSwapped can_eq_lhs2 ps_ty2 ty1 ps_ty1
+
+     -- If the type is TyConApp tc1 args1, then args1 really can't be less
+     -- than tyConArity tc1. It could be *more* than tyConArity, but then we
+     -- should have handled the case as an AppTy. That case only fires if
+     -- _both_ sides of the equality are AppTy-like... but if one side is
+     -- AppTy-like and the other isn't (and it also isn't a variable or
+     -- saturated type family application, both of which are handled by
+     -- can_eq_nc'), we're in a failure mode and can just fall through.
+
+----------------------------
+-- Fall-through. Give up.
+----------------------------
+
+-- We've rewritten and the types don't match. Give up.
+can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2
+  = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)
+       ; case eq_rel of -- See Note [Unsolved equalities]
+            ReprEq -> solveIrredEquality ReprEqReason ev
+            NomEq  -> solveIrredEquality ShapeMismatchReason ev }
+          -- No need to call canEqFailure/canEqHardFailure because they
+          -- rewrite, and the types involved here are already rewritten
+
+
+{- Note [Unsolved equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have an unsolved equality like
+  (a b ~R# Int)
+that is not necessarily insoluble!  Maybe 'a' will turn out to be a newtype.
+So we want to make it a potentially-soluble Irred not an insoluble one.
+Missing this point is what caused #15431
+-}
+
+---------------------------------
+can_eq_nc_forall :: CtEvidence -> EqRel
+                 -> Type -> Type    -- LHS and RHS
+                 -> TcS (StopOrContinue Ct)
+-- (forall as. phi1) ~ (forall bs. phi2)
+-- Check for length match of as, bs
+-- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs]
+-- But remember also to unify the kinds of as and bs
+--  (this is the 'go' loop), and actually substitute phi2[as |> cos / bs]
+-- Remember also that we might have forall z (a:z). blah
+--  so we must proceed one binder at a time (#13879)
+
+can_eq_nc_forall ev eq_rel s1 s2
+ | CtWanted { ctev_loc = loc, ctev_dest = orig_dest, ctev_rewriters = rewriters } <- ev
+ = do { let free_tvs       = tyCoVarsOfTypes [s1,s2]
+            (bndrs1, phi1) = tcSplitForAllTyVarBinders s1
+            (bndrs2, phi2) = tcSplitForAllTyVarBinders s2
+      ; if not (equalLength bndrs1 bndrs2)
+        then do { traceTcS "Forall failure" $
+                     vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2
+                          , ppr (binderFlags bndrs1)
+                          , ppr (binderFlags bndrs2) ]
+                ; canEqHardFailure ev s1 s2 }
+        else
+   do { traceTcS "Creating implication for polytype equality" $ ppr ev
+      ; let empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs
+      ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1)
+      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $
+                              binderVars bndrs1
+
+      ; let phi1' = substTy subst1 phi1
+
+            -- Unify the kinds, extend the substitution
+            go :: [TcTyVar] -> Subst -> [TyVarBinder]
+               -> TcS (TcCoercion, Cts)
+            go (skol_tv:skol_tvs) subst (bndr2:bndrs2)
+              = do { let tv2 = binderVar bndr2
+                   ; (kind_co, wanteds1) <- unify loc rewriters Nominal (tyVarKind skol_tv)
+                                                  (substTy subst (tyVarKind tv2))
+                   ; let subst' = extendTvSubstAndInScope subst tv2
+                                       (mkCastTy (mkTyVarTy skol_tv) kind_co)
+                         -- skol_tv is already in the in-scope set, but the
+                         -- free vars of kind_co are not; hence "...AndInScope"
+                   ; (co, wanteds2) <- go skol_tvs subst' bndrs2
+                   ; return ( mkForAllCo skol_tv kind_co co
+                            , wanteds1 `unionBags` wanteds2 ) }
+
+            -- Done: unify phi1 ~ phi2
+            go [] subst bndrs2
+              = assert (null bndrs2) $
+                unify loc rewriters (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)
+
+            go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) []
+
+            empty_subst2 = mkEmptySubst (getSubstInScope subst1)
+
+      ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $
+                                    go skol_tvs empty_subst2 bndrs2
+      ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds
+
+      ; setWantedEq orig_dest all_co
+      ; stopWith ev "Deferred polytype equality" } }
+
+ | otherwise
+ = do { traceTcS "Omitting decomposition of given polytype equality" $
+        pprEq s1 s2    -- See Note [Do not decompose Given polytype equalities]
+      ; stopWith ev "Discard given polytype equality" }
+
+ where
+    unify :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)
+    -- This version returns the wanted constraint rather
+    -- than putting it in the work list
+    unify loc rewriters role ty1 ty2
+      | ty1 `tcEqType` ty2
+      = return (mkReflCo role ty1, emptyBag)
+      | otherwise
+      = do { (wanted, co) <- newWantedEq loc rewriters role ty1 ty2
+           ; return (co, unitBag (mkNonCanonical wanted)) }
+
+---------------------------------
+-- | Compare types for equality, while zonking as necessary. Gives up
+-- as soon as it finds that two types are not equal.
+-- This is quite handy when some unification has made two
+-- types in an inert Wanted to be equal. We can discover the equality without
+-- rewriting, which is sometimes very expensive (in the case of type functions).
+-- In particular, this function makes a ~20% improvement in test case
+-- perf/compiler/T5030.
+--
+-- Returns either the (partially zonked) types in the case of
+-- inequality, or the one type in the case of equality. canEqReflexive is
+-- a good next step in the 'Right' case. Returning 'Left' is always safe.
+--
+-- NB: This does *not* look through type synonyms. In fact, it treats type
+-- synonyms as rigid constructors. In the future, it might be convenient
+-- to look at only those arguments of type synonyms that actually appear
+-- in the synonym RHS. But we're not there yet.
+zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType)
+zonk_eq_types = go
+  where
+    go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2
+    go (TyVarTy tv1) ty2           = tyvar NotSwapped tv1 ty2
+    go ty1 (TyVarTy tv2)           = tyvar IsSwapped  tv2 ty1
+
+    -- We handle FunTys explicitly here despite the fact that they could also be
+    -- treated as an application. Why? Well, for one it's cheaper to just look
+    -- at two types (the argument and result types) than four (the argument,
+    -- result, and their RuntimeReps). Also, we haven't completely zonked yet,
+    -- so we may run into an unzonked type variable while trying to compute the
+    -- RuntimeReps of the argument and result types. This can be observed in
+    -- testcase tc269.
+    go (FunTy af1 w1 arg1 res1) (FunTy af2 w2 arg2 res2)
+      | af1 == af2
+      , eqType w1 w2
+      = do { res_a <- go arg1 arg2
+           ; res_b <- go res1 res2
+           ; return $ combine_rev (FunTy af1 w1) res_b res_a }
+
+    go ty1@(FunTy {}) ty2 = bale_out ty1 ty2
+    go ty1 ty2@(FunTy {}) = bale_out ty1 ty2
+
+    go ty1 ty2
+      | Just (tc1, tys1) <- splitTyConAppNoView_maybe ty1
+      , Just (tc2, tys2) <- splitTyConAppNoView_maybe ty2
+      = if tc1 == tc2 && tys1 `equalLength` tys2
+          -- Crucial to check for equal-length args, because
+          -- we cannot assume that the two args to 'go' have
+          -- the same kind.  E.g go (Proxy *      (Maybe Int))
+          --                        (Proxy (*->*) Maybe)
+          -- We'll call (go (Maybe Int) Maybe)
+          -- See #13083
+        then tycon tc1 tys1 tys2
+        else bale_out ty1 ty2
+
+    go ty1 ty2
+      | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1
+      , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2
+      = do { res_a <- go ty1a ty2a
+           ; res_b <- go ty1b ty2b
+           ; return $ combine_rev mkAppTy res_b res_a }
+
+    go ty1@(LitTy lit1) (LitTy lit2)
+      | lit1 == lit2
+      = return (Right ty1)
+
+    go ty1 ty2 = bale_out ty1 ty2
+      -- We don't handle more complex forms here
+
+    bale_out ty1 ty2 = return $ Left (Pair ty1 ty2)
+
+    tyvar :: SwapFlag -> TcTyVar -> TcType
+          -> TcS (Either (Pair TcType) TcType)
+      -- Try to do as little as possible, as anything we do here is redundant
+      -- with rewriting. In particular, no need to zonk kinds. That's why
+      -- we don't use the already-defined zonking functions
+    tyvar swapped tv ty
+      = case tcTyVarDetails tv of
+          MetaTv { mtv_ref = ref }
+            -> do { cts <- readTcRef ref
+                  ; case cts of
+                      Flexi        -> give_up
+                      Indirect ty' -> do { trace_indirect tv ty'
+                                         ; unSwap swapped go ty' ty } }
+          _ -> give_up
+      where
+        give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty
+
+    tyvar_tyvar tv1 tv2
+      | tv1 == tv2 = return (Right (mkTyVarTy tv1))
+      | otherwise  = do { (ty1', progress1) <- quick_zonk tv1
+                        ; (ty2', progress2) <- quick_zonk tv2
+                        ; if progress1 || progress2
+                          then go ty1' ty2'
+                          else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) }
+
+    trace_indirect tv ty
+       = traceTcS "Following filled tyvar (zonk_eq_types)"
+                  (ppr tv <+> equals <+> ppr ty)
+
+    quick_zonk tv = case tcTyVarDetails tv of
+      MetaTv { mtv_ref = ref }
+        -> do { cts <- readTcRef ref
+              ; case cts of
+                  Flexi        -> return (TyVarTy tv, False)
+                  Indirect ty' -> do { trace_indirect tv ty'
+                                     ; return (ty', True) } }
+      _ -> return (TyVarTy tv, False)
+
+      -- This happens for type families, too. But recall that failure
+      -- here just means to try harder, so it's OK if the type function
+      -- isn't injective.
+    tycon :: TyCon -> [TcType] -> [TcType]
+          -> TcS (Either (Pair TcType) TcType)
+    tycon tc tys1 tys2
+      = do { results <- zipWithM go tys1 tys2
+           ; return $ case combine_results results of
+               Left tys  -> Left (mkTyConApp tc <$> tys)
+               Right tys -> Right (mkTyConApp tc tys) }
+
+    combine_results :: [Either (Pair TcType) TcType]
+                    -> Either (Pair [TcType]) [TcType]
+    combine_results = bimap (fmap reverse) reverse .
+                      foldl' (combine_rev (:)) (Right [])
+
+      -- combine (in reverse) a new result onto an already-combined result
+    combine_rev :: (a -> b -> c)
+                -> Either (Pair b) b
+                -> Either (Pair a) a
+                -> Either (Pair c) c
+    combine_rev f (Left list) (Left elt) = Left (f <$> elt     <*> list)
+    combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list)
+    combine_rev f (Right tys) (Left elt) = Left (f <$> elt     <*> pure tys)
+    combine_rev f (Right tys) (Right ty) = Right (f ty tys)
+
+{- Note [Unwrap newtypes first]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also Note [Decomposing newtype equalities]
+
+Consider
+  newtype N m a = MkN (m a)
+N will get a conservative, Nominal role for its second parameter 'a',
+because it appears as an argument to the unknown 'm'. Now consider
+  [W] N Maybe a  ~R#  N Maybe b
+
+If we /decompose/, we'll get
+  [W] a ~N# b
+
+But if instead we /unwrap/ we'll get
+  [W] Maybe a ~R# Maybe b
+which in turn gives us
+  [W] a ~R# b
+which is easier to satisfy.
+
+Conclusion: we must unwrap newtypes before decomposing them. This happens
+in `can_eq_newtype_nc`
+
+We did flirt with making the /rewriter/ expand newtypes, rather than
+doing it in `can_eq_newtype_nc`.   But with recursive newtypes we want
+to be super-careful about expanding!
+
+   newtype A = MkA [A]   -- Recursive!
+
+   f :: A -> [A]
+   f = coerce
+
+We have [W] A ~R# [A].  If we rewrite [A], it'll expand to
+   [[[[[...]]]]]
+and blow the reduction stack.  See Note [Newtypes can blow the stack]
+in GHC.Tc.Solver.Rewrite.  But if we expand only the /top level/ of
+both sides, we get
+   [W] [A] ~R# [A]
+which we can, just, solve by reflexivity.
+
+So we simply unwrap, on-demand, at top level, in `can_eq_newtype_nc`.
+
+This is all very delicate. There is a real risk of a loop in the type checker
+with recursive newtypes -- but I think we're doomed to do *something*
+delicate, as we're really trying to solve for equirecursive type
+equality. Bottom line for users: recursive newtypes do not play well with type
+inference for representational equality.  See also Section 5.3.1 and 5.3.4 of
+"Safe Zero-cost Coercions for Haskell" (JFP 2016).
+
+See also Note [Decomposing newtype equalities].
+
+--- Historical side note ---
+
+We flirted with doing /both/ unwrap-at-top-level /and/ rewrite-deeply;
+see #22519.  But that didn't work: see discussion in #22924. Specifically
+we got a loop with a minor variation:
+   f2 :: a -> [A]
+   f2 = coerce
+
+Note [Eager reflexivity check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+  newtype X = MkX (Int -> X)
+
+and
+
+  [W] X ~R X
+
+Naively, we would start unwrapping X and end up in a loop. Instead,
+we do this eager reflexivity check. This is necessary only for representational
+equality because the rewriter technology deals with the similar case
+(recursive type families) for nominal equality.
+
+Note that this check does not catch all cases, but it will catch the cases
+we're most worried about, types like X above that are actually inhabited.
+
+Here's another place where this reflexivity check is key:
+Consider trying to prove (f a) ~R (f a). The AppTys in there can't
+be decomposed, because representational equality isn't congruent with respect
+to AppTy. So, when canonicalising the equality above, we get stuck and
+would normally produce a CIrredCan. However, we really do want to
+be able to solve (f a) ~R (f a). So, in the representational case only,
+we do a reflexivity check.
+
+(This would be sound in the nominal case, but unnecessary, and I [Richard
+E.] am worried that it would slow down the common case.)
+
+ Note [Newtypes can blow the stack]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+  newtype X = MkX (Int -> X)
+  newtype Y = MkY (Int -> Y)
+
+and now wish to prove
+
+  [W] X ~R Y
+
+This Wanted will loop, expanding out the newtypes ever deeper looking
+for a solid match or a solid discrepancy. Indeed, there is something
+appropriate to this looping, because X and Y *do* have the same representation,
+in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized
+coercion will ever witness it. This loop won't actually cause GHC to hang,
+though, because we check our depth in `can_eq_newtype_nc`.
+-}
+
+------------------------
+-- | We're able to unwrap a newtype. Update the bits accordingly.
+can_eq_newtype_nc :: CtEvidence           -- ^ :: ty1 ~ ty2
+                  -> SwapFlag
+                  -> TcType                                    -- ^ ty1
+                  -> ((Bag GlobalRdrElt, TcCoercion), TcType)  -- ^ :: ty1 ~ ty1'
+                  -> TcType               -- ^ ty2
+                  -> TcType               -- ^ ty2, with type synonyms
+                  -> TcS (StopOrContinue Ct)
+can_eq_newtype_nc ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2
+  = do { traceTcS "can_eq_newtype_nc" $
+         vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ]
+
+         -- Check for blowing our stack, and increase the depth
+         -- See Note [Newtypes can blow the stack]
+       ; let loc = ctEvLoc ev
+             ev' = ev `setCtEvLoc` bumpCtLocDepth loc
+       ; checkReductionDepth loc ty1
+
+         -- Next, we record uses of newtype constructors, since coercing
+         -- through newtypes is tantamount to using their constructors.
+       ; recordUsedGREs gres
+
+       ; let redn1 = mkReduction co1 ty1'
+
+       ; new_ev <- rewriteEqEvidence emptyRewriterSet ev' swapped
+                     redn1
+                     (mkReflRedn Representational ps_ty2)
+       ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
+
+---------
+-- ^ Decompose a type application.
+-- All input types must be rewritten. See Note [Canonicalising type applications]
+-- Nominal equality only!
+can_eq_app :: CtEvidence       -- :: s1 t1 ~N s2 t2
+           -> Xi -> Xi         -- s1 t1
+           -> Xi -> Xi         -- s2 t2
+           -> TcS (StopOrContinue Ct)
+
+-- AppTys only decompose for nominal equality, so this case just leads
+-- to an irreducible constraint; see typecheck/should_compile/T10494
+-- See Note [Decomposing AppTy equalities]
+can_eq_app ev s1 t1 s2 t2
+  | CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } <- ev
+  = do { co_s <- unifyWanted rewriters loc Nominal s1 s2
+       ; let arg_loc
+               | isNextArgVisible s1 = loc
+               | otherwise           = updateCtLocOrigin loc toInvisibleOrigin
+       ; co_t <- unifyWanted rewriters arg_loc Nominal t1 t2
+       ; let co = mkAppCo co_s co_t
+       ; setWantedEq dest co
+       ; stopWith ev "Decomposed [W] AppTy" }
+
+    -- If there is a ForAll/(->) mismatch, the use of the Left coercion
+    -- below is ill-typed, potentially leading to a panic in splitTyConApp
+    -- Test case: typecheck/should_run/Typeable1
+    -- We could also include this mismatch check above (for W and D), but it's slow
+    -- and we'll get a better error message not doing it
+  | s1k `mismatches` s2k
+  = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2)
+
+  | CtGiven { ctev_evar = evar } <- ev
+  = do { let co   = mkCoVarCo evar
+             co_s = mkLRCo CLeft  co
+             co_t = mkLRCo CRight co
+       ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2
+                                     , evCoercion co_s )
+       ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2
+                                     , evCoercion co_t )
+       ; emitWorkNC [evar_t]
+       ; solveNonCanonicalEquality evar_s NomEq s1 s2 }
+
+  where
+    loc = ctEvLoc ev
+
+    s1k = typeKind s1
+    s2k = typeKind s2
+
+    k1 `mismatches` k2
+      =  isForAllTy k1 && not (isForAllTy k2)
+      || not (isForAllTy k1) && isForAllTy k2
+
+-----------------------
+-- | Break apart an equality over a casted type
+-- looking like   (ty1 |> co1) ~ ty2   (modulo a swap-flag)
+canEqCast :: Bool         -- are both types rewritten?
+          -> CtEvidence
+          -> EqRel
+          -> SwapFlag
+          -> TcType -> Coercion   -- LHS (res. RHS), ty1 |> co1
+          -> TcType -> TcType     -- RHS (res. LHS), ty2 both normal and pretty
+          -> TcS (StopOrContinue Ct)
+canEqCast rewritten ev eq_rel swapped ty1 co1 ty2 ps_ty2
+  = do { traceTcS "Decomposing cast" (vcat [ ppr ev
+                                           , ppr ty1 <+> text "|>" <+> ppr co1
+                                           , ppr ps_ty2 ])
+       ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
+                      (mkGReflLeftRedn role ty1 co1)
+                      (mkReflRedn role ps_ty2)
+       ; can_eq_nc rewritten new_ev eq_rel ty1 ty1 ty2 ps_ty2 }
+  where
+    role = eqRelRole eq_rel
+
+------------------------
+canTyConApp :: CtEvidence -> EqRel
+            -> TyCon -> [TcType]
+            -> TyCon -> [TcType]
+            -> TcS (StopOrContinue Ct)
+-- See Note [Decomposing TyConApp equalities]
+-- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
+-- Neither tc1 nor tc2 is a saturated funTyCon, nor a type family
+-- But they can be data families.
+canTyConApp ev eq_rel tc1 tys1 tc2 tys2
+  | tc1 == tc2
+  , tys1 `equalLength` tys2
+  = do { inerts <- getTcSInerts
+       ; if can_decompose inerts
+         then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2
+         else canEqFailure ev eq_rel ty1 ty2 }
+
+  -- See Note [Skolem abstract data] in GHC.Core.Tycon
+  | tyConSkolem tc1 || tyConSkolem tc2
+  = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)
+       ; solveIrredEquality AbstractTyConReason ev }
+
+  -- Fail straight away for better error messages
+  -- See Note [Use canEqFailure in canDecomposableTyConApp]
+  | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational &&
+                             isGenerativeTyCon tc2 Representational)
+  = canEqFailure ev eq_rel ty1 ty2
+
+  | otherwise
+  = canEqHardFailure ev ty1 ty2
+  where
+    -- Reconstruct the types for error messages. This would do
+    -- the wrong thing (from a pretty printing point of view)
+    -- for functions, because we've lost the FunTyFlag; but
+    -- in fact we never call canTyConApp on a saturated FunTyCon
+    ty1 = mkTyConApp tc1 tys1
+    ty2 = mkTyConApp tc2 tys2
+
+     -- See Note [Decomposing TyConApp equalities]
+     -- and Note [Decomposing newtype equalities]
+    can_decompose inerts
+      =  isInjectiveTyCon tc1 (eqRelRole eq_rel)
+      || (assert (eq_rel == ReprEq) $
+          -- assert: isInjectiveTyCon is always True for Nominal except
+          --   for type synonyms/families, neither of which happen here
+          -- Moreover isInjectiveTyCon is True for Representational
+          --   for algebraic data types.  So we are down to newtypes
+          --   and data families.
+          ctEvFlavour ev == Wanted && noGivenNewtypeReprEqs tc1 inerts)
+             -- See Note [Decomposing newtype equalities] (EX2)
+
+{-
+Note [Use canEqFailure in canDecomposableTyConApp]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must use canEqFailure, not canEqHardFailure here, because there is
+the possibility of success if working with a representational equality.
+Here is one case:
+
+  type family TF a where TF Char = Bool
+  data family DF a
+  newtype instance DF Bool = MkDF Int
+
+Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet
+know `a`. This is *not* a hard failure, because we might soon learn
+that `a` is, in fact, Char, and then the equality succeeds.
+
+Here is another case:
+
+  [G] Age ~R Int
+
+where Age's constructor is not in scope. We don't want to report
+an "inaccessible code" error in the context of this Given!
+
+For example, see typecheck/should_compile/T10493, repeated here:
+
+  import Data.Ord (Down)  -- no constructor
+
+  foo :: Coercible (Down Int) Int => Down Int -> Int
+  foo = coerce
+
+That should compile, but only because we use canEqFailure and not
+canEqHardFailure.
+
+Note [Fast path when decomposing TyConApps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see (T s1 t1 ~ T s2 t2), then we can just decompose to
+  (s1 ~ s2, t1 ~ t2)
+and push those back into the work list.  But if
+  s1 = K k1    s2 = K k2
+then we will just decompose s1~s2, and it might be better to
+do so on the spot.  An important special case is where s1=s2,
+and we get just Refl.
+
+So canDecomposableTyConAppOK uses unifyWanted etc to short-cut that work.
+See also Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
+
+Note [Decomposing TyConApp equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+        [G/W] T ty1 ~r T ty2
+Can we decompose it, and replace it by
+        [G/W] ty1 ~r' ty2
+and if so what role is r'?  (In this Note, all the "~" are primitive
+equalities "~#", but I have dropped the noisy "#" symbols.)  Lots of
+background in the paper "Safe zero-cost coercions for Haskell".
+
+This Note covers the topic for
+  * Datatypes
+  * Newtypes
+  * Data families
+For the rest:
+  * Type synonyms: are always expanded
+  * Type families: see Note [Decomposing type family applications]
+  * AppTy:         see Note [Decomposing AppTy equalities].
+
+---- Roles of the decomposed constraints ----
+For a start, the role r' will always be defined like this:
+  * If r=N then r' = N
+  * If r=R then r' = role of T's first argument
+
+For example:
+   data TR a = MkTR a       -- Role of T's first arg is Representational
+   data TN a = MkTN (F a)   -- Role of T's first arg is Nominal
+
+The function tyConRolesX :: Role -> TyCon -> [Role] gets the argument
+role r' for a TyCon T at role r.  E.g.
+   tyConRolesX Nominal          TR = [Nominal]
+   tyConRolesX Representational TR = [Representational]
+
+---- Soundness and completeness ----
+For Givens, for /soundness/ of decomposition we need, forall ty1,ty2:
+    T ty1 ~r T ty2   ===>    ty1 ~r' ty2
+Here "===>" means "implies".  That is, given evidence for (co1 : T ty1 ~r T co2)
+we can produce evidence for (co2 : ty1 ~r' ty2).  But in the solver we
+/replace/ co1 with co2 in the inert set, and we don't want to lose any proofs
+thereby. So for /completeness/ of decomposition we also need the reverse:
+    ty1 ~r' ty2   ===>    T ty1 ~r T ty2
+
+For Wanteds, for /soundness/ of decomposition we need:
+    ty1 ~r' ty2   ===>    T ty1 ~r T ty2
+because if we do decompose we'll get evidence (co2 : ty1 ~r' ty2) and
+from that we want to derive evidence (T co2 : T ty1 ~r T ty2).
+For /completeness/ of decomposition we need the reverse implication too,
+else we may decompose to a new proof obligation that is stronger than
+the one we started with.  See Note [Decomposing newtype equalities].
+
+---- Injectivity ----
+When do these bi-implications hold? In one direction it is easy.
+We /always/ have
+    ty1 ~r'  ty2   ===>    T ty1 ~r T ty2
+This is the CO_TYCONAPP rule of the paper (Fig 5); see also the
+TyConAppCo case of GHC.Core.Lint.lintCoercion.
+
+In the other direction, we have
+    T ty1 ~r T ty2   ==>   ty1 ~r' ty2  if T is /injective at role r/
+This is the very /definition/ of injectivity: injectivity means result
+is the same => arguments are the same, modulo the role shift.
+See comments on GHC.Core.TyCon.isInjectiveTyCon.  This is also
+the CO_NTH rule in Fig 5 of the paper, except in the paper only
+newtypes are non-injective at representation role, so the rule says "H
+is not a newtype".
+
+Injectivity is a bit subtle:
+                 Nominal   Representational
+   Datatype        YES        YES
+   Newtype         YES        NO{1}
+   Data family     YES        NO{2}
+
+{1} Consider newtype N a = MkN (F a)   -- Arg has Nominal role
+    Is it true that (N t1) ~R (N t2)   ==>   t1 ~N t2  ?
+    No, absolutely not.  E.g.
+       type instance F Int = Int; type instance F Bool = Char
+       Then (N Int) ~R (N Bool), by unwrapping, but we don't want Int~Char!
+
+    See Note [Decomposing newtype equalities]
+
+{2} We must treat data families precisely like newtypes, because of the
+    possibility of newtype instances. See also
+    Note [Decomposing newtype equalities]. See #10534 and
+    test case typecheck/should_fail/T10534.
+
+---- Takeaway summary -----
+For sound and complete decomposition, we simply need injectivity;
+that is for isInjectiveTyCon to be true:
+
+* At Nominal role, isInjectiveTyCon is True for all the TyCons we are
+  considering in this Note: datatypes, newtypes, and data families.
+
+* For Givens, injectivity is necessary for soundness; completeness has no
+  side conditions.
+
+* For Wanteds, soundness has no side conditions; but injectivity is needed
+  for completeness. See Note [Decomposing newtype equalities]
+
+This is implemented in `can_decompose` in `canTyConApp`; it looks at
+injectivity, just as specified above.
+
+
+Note [Decomposing type family applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Supose we have
+   [G/W]  (F ty1) ~r  (F ty2)
+This is handled by the TyFamLHS/TyFamLHS case of canEqCanLHS2.
+
+We never decompose to
+   [G/W]  ty1 ~r' ty2
+
+Instead
+
+* For Givens we do nothing. Injective type families have no corresponding
+  evidence of their injectivity, so we cannot decompose an
+  injective-type-family Given.
+
+* For Wanteds, for the Nominal role only, we emit new Wanteds rather like
+  functional dependencies, for each injective argument position.
+
+  E.g type family F a b   -- injective in first arg, but not second
+      [W] (F s1 t1) ~N (F s2 t2)
+  Emit new Wanteds
+      [W] s1 ~N s2
+  But retain the existing, unsolved constraint.
+
+Note [Decomposing newtype equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This Note also applies to data families, which we treat like
+newtype in case of 'newtype instance'.
+
+As Note [Decomposing TyConApp equalities] describes, if N is injective
+at role r, we can do this decomposition?
+   [G/W] (N ty1) ~r (N ty2)    to     [G/W]  ty1 ~r' ty2
+
+For a Given with r=R, the answer is a solid NO: newtypes are not injective at
+representational role, and we must not decompose, or we lose soundness.
+Example is wrinkle {1} in Note [Decomposing TyConApp equalities].
+
+For a Wanted with r=R, since newtypes are not injective at representational
+role, decomposition is sound, but we may lose completeness.  Nevertheless,
+if the newtype is abstract (so can't be unwrapped) we can only solve
+the equality by (a) using a Given or (b) decomposition.  If (a) is impossible
+(e.g. no Givens) then (b) is safe albeit potentially incomplete.
+
+There are two ways in which decomposing (N ty1) ~r (N ty2) could be incomplete:
+
+* Incompleteness example (EX1): unwrap first
+      newtype Nt a = MkNt (Id a)
+      type family Id a where Id a = a
+
+      [W] Nt Int ~R Nt Age
+
+  Because of its use of a type family, Nt's parameter will get inferred to
+  have a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age,
+  which is unsatisfiable. Unwrapping, though, leads to a solution.
+
+  Conclusion: always unwrap newtypes before attempting to decompose
+  them.  This is done in can_eq_nc'.  Of course, we can't unwrap if the data
+  constructor isn't in scope.  See Note [Unwrap newtypes first].
+
+* Incompleteness example (EX2): available Givens
+      newtype Nt a = Mk Bool         -- NB: a is not used in the RHS,
+      type role Nt representational  -- but the user gives it an R role anyway
+
+      [G] Nt t1 ~R Nt t2
+      [W] Nt alpha ~R Nt beta
+
+  We *don't* want to decompose to [W] alpha ~R beta, because it's possible
+  that alpha and beta aren't representationally equal.  And if we figure
+  out (elsewhere) that alpha:=t1 and beta:=t2, we can solve the Wanted
+  from the Given.  This is somewhat similar to the question of overlapping
+  Givens for class constraints: see Note [Instance and Given overlap] in
+  GHC.Tc.Solver.Interact.
+
+  Conclusion: don't decompose [W] N s ~R N t, if there are any Given
+  equalities that could later solve it.
+
+  But what precisely does it mean to say "any Given equalities that could
+  later solve it"?
+
+  In #22924 we had
+     [G] f a ~R# a     [W] Const (f a) a ~R# Const a a
+  where Const is an abstract newtype.  If we decomposed the newtype, we
+  could solve.  Not-decomposing on the grounds that (f a ~R# a) might turn
+  into (Const (f a) a ~R# Const a a) seems a bit silly.
+
+  In #22331 we had
+     [G] N a ~R# N b   [W] N b ~R# N a
+  (where N is abstract so we can't unwrap). Here we really /don't/ want to
+  decompose, because the /only/ way to solve the Wanted is from that Given
+  (with a Sym).
+
+  In #22519 we had
+     [G] a <= b     [W] IO Age ~R# IO Int
+
+  (where IO is abstract so we can't unwrap, and newtype Age = Int; and (<=)
+  is a type-level comparison on Nats).  Here we /must/ decompose, despite the
+  existence of an Irred Given, or we will simply be stuck.  (Side note: We
+  flirted with deep-rewriting of newtypes (see discussion on #22519 and
+  !9623) but that turned out not to solve #22924, and also makes type
+  inference loop more often on recursive newtypes.)
+
+  The currently-implemented compromise is this:
+
+    we decompose [W] N s ~R# N t unless there is a [G] N s' ~ N t'
+
+  that is, a Given Irred equality with both sides headed with N.
+  See the call to noGivenNewtypeReprEqs in canTyConApp.
+
+  This is not perfect.  In principle a Given like [G] (a b) ~ (c d), or
+  even just [G] c, could later turn into N s ~ N t.  But since the free
+  vars of a Given are skolems, or at least untouchable unification
+  variables, this is extremely unlikely to happen.
+
+  Another worry: there could, just, be a CDictCan with some
+  un-expanded equality superclasses; but only in some very obscure
+  recursive-superclass situations.
+
+   Yet another approach (!) is desribed in
+   Note [Decomposing newtypes a bit more aggressively].
+
+Remember: decomposing Wanteds is always /sound/. This Note is
+only about /completeness/.
+
+Note [Decomposing newtypes a bit more aggressively]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+IMPORTANT: the ideas in this Note are *not* implemented. Instead, the
+current approach is detailed in Note [Decomposing newtype equalities]
+and Note [Unwrap newtypes first].
+For more details about the ideas in this Note see
+  * GHC propoosal: https://github.com/ghc-proposals/ghc-proposals/pull/549
+  * issue #22441
+  * discussion on !9282.
+
+Consider [G] c, [W] (IO Int) ~R (IO Age)
+where IO is abstract, and
+   newtype Age = MkAge Int   -- Not abstract
+With the above rules, if there any Given Irreds,
+the Wanted is insoluble because we can't decompose it.  But in fact,
+if we look at the defn of IO, roughly,
+    newtype IO a = State# -> (State#, a)
+we can see that decomposing [W] (IO Int) ~R (IO Age) to
+    [W] Int ~R Age
+definitely does not lose completeness. Why not? Because the role of
+IO's argment is representational.  Hence:
+
+  DecomposeNewtypeIdea:
+     decompose [W] (N s1 .. sn) ~R (N t1 .. tn)
+     if the roles of all N's arguments are representational
+
+If N's arguments really /are/ representational this will not lose
+completeness.  Here "really are representational" means "if you expand
+all newtypes in N's RHS, we'd infer a representational role for each
+of N's type variables in that expansion".  See Note [Role inference]
+in GHC.Tc.TyCl.Utils.
+
+But the user might /override/ a phantom role with an explicit role
+annotation, and then we could (obscurely) get incompleteness.
+Consider
+
+   module A( silly, T ) where
+     newtype T a = MkT Int
+     type role T representational  -- Override phantom role
+
+     silly :: Coercion (T Int) (T Bool)
+     silly = Coercion  -- Typechecks by unwrapping the newtype
+
+     data Coercion a b where  -- Actually defined in Data.Type.Coercion
+       Coercion :: Coercible a b => Coercion a b
+
+   module B where
+     import A
+     f :: T Int -> T Bool
+     f = case silly of Coercion -> coerce
+
+Here the `coerce` gives [W] (T Int) ~R (T Bool) which, if we decompose,
+we'll get stuck with (Int ~R Bool).  Instead we want to use the
+[G] (T Int) ~R (T Bool), which will be in the Irreds.
+
+Summary: we could adopt (DecomposeNewtypeIdea), at the cost of a very
+obscure incompleteness (above).  But no one is reporting a problem from
+the lack of decompostion, so we'll just leave it for now.  This long
+Note is just to record the thinking for our future selves.
+
+Note [Decomposing AppTy equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For AppTy all the same questions arise as in
+Note [Decomposing TyConApp equalities]. We have
+
+    s1 ~r s2,  t1 ~N t2   ==>   s1 t1 ~r s2 t2       (rule CO_APP)
+    s1 t1 ~N s2 t2        ==>   s1 ~N s2,  t1 ~N t2  (CO_LEFT, CO_RIGHT)
+
+In the first of these, why do we need Nominal equality in (t1 ~N t2)?
+See {2} below.
+
+For sound and complete solving, we need both directions to decompose. So:
+* At nominal role, all is well: we have both directions.
+* At representational role, decomposition of Givens is unsound (see {1} below),
+  and decomposition of Wanteds is incomplete.
+
+Here is an example of the incompleteness for Wanteds:
+
+    [G] g1 :: a ~R b
+    [W] w1 :: Maybe b ~R alpha a
+    [W] w2 :: alpha ~N Maybe
+
+Suppose we see w1 before w2. If we decompose, using AppCo to prove w1, we get
+
+    w1 := AppCo w3 w4
+    [W] w3 :: Maybe ~R alpha
+    [W] w4 :: b ~N a
+
+Note that w4 is *nominal*. A nominal role here is necessary because AppCo
+requires a nominal role on its second argument. (See {2} for an example of
+why.) Now we are stuck, because w4 is insoluble. On the other hand, if we
+see w2 first, setting alpha := Maybe, all is well, as we can decompose
+Maybe b ~R Maybe a into b ~R a.
+
+Another example:
+    newtype Phant x = MkPhant Int
+    [W] w1 :: Phant Int ~R alpha Bool
+    [W] w2 :: alpha ~ Phant
+
+If we see w1 first, decomposing would be disastrous, as we would then try
+to solve Int ~ Bool. Instead, spotting w2 allows us to simplify w1 to become
+    [W] w1' :: Phant Int ~R Phant Bool
+
+which can then (assuming MkPhant is in scope) be simplified to Int ~R Int,
+and all will be well. See also Note [Unwrap newtypes first].
+
+Bottom line:
+* Always decompose AppTy at nominal role: can_eq_app
+* Never decompose AppTy at representational role (neither Given nor Wanted):
+  the lack of an equation in can_eq_nc'
+
+Extra points
+{1}  Decomposing a Given AppTy over a representational role is simply
+     unsound. For example, if we have co1 :: Phant Int ~R a Bool (for
+     the newtype Phant, above), then we surely don't want any relationship
+     between Int and Bool, lest we also have co2 :: Phant ~ a around.
+
+{2} The role on the AppCo coercion is a conservative choice, because we don't
+    know the role signature of the function. For example, let's assume we could
+    have a representational role on the second argument of AppCo. Then, consider
+
+    data G a where    -- G will have a nominal role, as G is a GADT
+      MkG :: G Int
+    newtype Age = MkAge Int
+
+    co1 :: G ~R a        -- by assumption
+    co2 :: Age ~R Int    -- by newtype axiom
+    co3 = AppCo co1 co2 :: G Age ~R a Int    -- by our broken AppCo
+
+    and now co3 can be used to cast MkG to have type G Age, in violation of
+    the way GADTs are supposed to work (which is to use nominal equality).
+-}
+
+canDecomposableTyConAppOK :: CtEvidence -> EqRel
+                          -> TyCon -> [TcType] -> [TcType]
+                          -> TcS (StopOrContinue Ct)
+-- Precondition: tys1 and tys2 are the same finite length, hence "OK"
+canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
+  = assert (tys1 `equalLength` tys2) $
+    do { traceTcS "canDecomposableTyConAppOK"
+                  (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)
+       ; case ev of
+           CtWanted { ctev_dest = dest, ctev_rewriters = rewriters }
+                  -- new_locs and tc_roles are both infinite, so
+                  -- we are guaranteed that cos has the same lengthm
+                  -- as tys1 and tys2
+                  -- See Note [Fast path when decomposing TyConApps]
+                  -- Caution: unifyWanteds is order sensitive
+                  -- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
+             -> do { cos <- unifyWanteds rewriters new_locs tc_roles tys1 tys2
+                   ; setWantedEq dest (mkTyConAppCo role tc cos) }
+
+           CtGiven { ctev_evar = evar }
+             -> do { let ev_co = mkCoVarCo evar
+                   ; given_evs <- newGivenEvVars loc $
+                                  [ ( mkPrimEqPredRole r ty1 ty2
+                                    , evCoercion $ mkSelCo (SelTyCon i r) ev_co )
+                                  | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]
+                                  , r /= Phantom
+                                  , not (isCoercionTy ty1) && not (isCoercionTy ty2) ]
+                   ; emitWorkNC given_evs }
+
+    ; stopWith ev "Decomposed TyConApp" }
+
+  where
+    loc  = ctEvLoc ev
+    role = eqRelRole eq_rel
+
+    -- Infinite, to allow for over-saturated TyConApps
+    tc_roles = tyConRoleListX role tc
+
+      -- Add nuances to the location during decomposition:
+      --  * if the argument is a kind argument, remember this, so that error
+      --    messages say "kind", not "type". This is determined based on whether
+      --    the corresponding tyConBinder is named (that is, dependent)
+      --  * if the argument is invisible, note this as well, again by
+      --    looking at the corresponding binder
+      -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't
+      -- do either of these changes. (Forgetting to do so led to #16188)
+      --
+      -- NB: infinite in length
+    new_locs = [ new_loc
+               | bndr <- tyConBinders tc
+               , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc
+                              | otherwise               = loc
+                     new_loc  | isInvisibleTyConBinder bndr
+                              = updateCtLocOrigin new_loc0 toInvisibleOrigin
+                              | otherwise
+                              = new_loc0 ]
+               ++ repeat loc
+
+canDecomposableFunTy :: CtEvidence -> EqRel -> FunTyFlag
+                     -> (Type,Type,Type)   -- (multiplicity,arg,res)
+                     -> (Type,Type,Type)   -- (multiplicity,arg,res)
+                     -> TcS (StopOrContinue Ct)
+canDecomposableFunTy ev eq_rel af f1@(m1,a1,r1) f2@(m2,a2,r2)
+  = do { traceTcS "canDecomposableFunTy"
+                  (ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2)
+       ; case ev of
+           CtWanted { ctev_dest = dest, ctev_rewriters = rewriters }
+             -> do { mult <- unifyWanted rewriters mult_loc (funRole role SelMult) m1 m2
+                   ; arg  <- unifyWanted rewriters loc      (funRole role SelArg)  a1 a2
+                   ; res  <- unifyWanted rewriters loc      (funRole role SelRes)  r1 r2
+                   ; setWantedEq dest (mkNakedFunCo1 role af mult arg res) }
+
+           CtGiven { ctev_evar = evar }
+             -> do { let ev_co = mkCoVarCo evar
+                   ; given_evs <- newGivenEvVars loc $
+                                  [ ( mkPrimEqPredRole role' ty1 ty2
+                                    , evCoercion $ mkSelCo (SelFun fs) ev_co )
+                                  | (fs, ty1, ty2) <- [(SelMult, m1, m2)
+                                                      ,(SelArg,  a1, a2)
+                                                      ,(SelRes,  r1, r2)]
+                                  , let role' = funRole role fs ]
+                   ; emitWorkNC given_evs }
+
+    ; stopWith ev "Decomposed TyConApp" }
+
+  where
+    loc      = ctEvLoc ev
+    role     = eqRelRole eq_rel
+    mult_loc = updateCtLocOrigin loc toInvisibleOrigin
+
+-- | Call when canonicalizing an equality fails, but if the equality is
+-- representational, there is some hope for the future.
+-- Examples in Note [Use canEqFailure in canDecomposableTyConApp]
+canEqFailure :: CtEvidence -> EqRel
+             -> TcType -> TcType -> TcS (StopOrContinue Ct)
+canEqFailure ev NomEq ty1 ty2
+  = canEqHardFailure ev ty1 ty2
+canEqFailure ev ReprEq ty1 ty2
+  = do { (redn1, rewriters1) <- rewrite ev ty1
+       ; (redn2, rewriters2) <- rewrite ev ty2
+            -- We must rewrite the types before putting them in the
+            -- inert set, so that we are sure to kick them out when
+            -- new equalities become available
+       ; traceTcS "canEqFailure with ReprEq" $
+         vcat [ ppr ev, ppr redn1, ppr redn2 ]
+       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
+       ; continueWith (mkIrredCt ReprEqReason new_ev) }
+
+-- | Call when canonicalizing an equality fails with utterly no hope.
+canEqHardFailure :: CtEvidence
+                 -> TcType -> TcType -> TcS (StopOrContinue Ct)
+-- See Note [Make sure that insolubles are fully rewritten]
+canEqHardFailure ev ty1 ty2
+  = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)
+       ; (redn1, rewriters1) <- rewriteForErrors ev ty1
+       ; (redn2, rewriters2) <- rewriteForErrors ev ty2
+       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
+       ; continueWith (mkIrredCt ShapeMismatchReason new_ev) }
+
+{-
+Note [Canonicalising type applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given (s1 t1) ~ ty2, how should we proceed?
+The simple thing is to see if ty2 is of form (s2 t2), and
+decompose.
+
+However, over-eager decomposition gives bad error messages
+for things like
+   a b ~ Maybe c
+   e f ~ p -> q
+Suppose (in the first example) we already know a~Array.  Then if we
+decompose the application eagerly, yielding
+   a ~ Maybe
+   b ~ c
+we get an error        "Can't match Array ~ Maybe",
+but we'd prefer to get "Can't match Array b ~ Maybe c".
+
+So instead can_eq_wanted_app rewrites the LHS and RHS, in the hope of
+replacing (a b) by (Array b), before using try_decompose_app to
+decompose it.
+
+Note [Make sure that insolubles are fully rewritten]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When an equality fails, we still want to rewrite the equality
+all the way down, so that it accurately reflects
+ (a) the mutable reference substitution in force at start of solving
+ (b) any ty-binds in force at this point in solving
+See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet.
+And if we don't do this there is a bad danger that
+GHC.Tc.Solver.applyTyVarDefaulting will find a variable
+that has in fact been substituted.
+
+Note [Do not decompose Given polytype equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider [G] (forall a. t1 ~ forall a. t2).  Can we decompose this?
+No -- what would the evidence look like?  So instead we simply discard
+this given evidence.
+
+Note [No top-level newtypes on RHS of representational equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we're in this situation:
+
+ work item:  [W] c1 : a ~R b
+     inert:  [G] c2 : b ~R Id a
+
+where
+  newtype Id a = Id a
+
+We want to make sure canEqCanLHS sees [W] a ~R a, after b is rewritten
+and the Id newtype is unwrapped. This is assured by requiring only rewritten
+types in canEqCanLHS *and* having the newtype-unwrapping check above
+the tyvar check in can_eq_nc.
+
+Note that this only applies to saturated applications of newtype TyCons, as
+we can't rewrite an unsaturated application. See for example T22310, where
+we ended up with:
+
+  newtype Compose f g a = ...
+
+  [W] t[tau] ~# Compose Foo Bar
+
+Note [Put touchable variables on the left]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Ticket #10009, a very nasty example:
+
+    f :: (UnF (F b) ~ b) => F b -> ()
+
+    g :: forall a. (UnF (F a) ~ a) => a -> ()
+    g _ = f (undefined :: F a)
+
+For g we get [G]  g1 : UnF (F a) ~ a
+             [W] w1 : UnF (F beta) ~ beta
+             [W] w2 : F a ~ F beta
+
+g1 is canonical (CEqCan). It is oriented as above because a is not touchable.
+See canEqTyVarFunEq.
+
+w1 is similarly canonical, though the occurs-check in canEqTyVarFunEq is key
+here.
+
+w2 is canonical. But which way should it be oriented? As written, we'll be
+stuck. When w2 is added to the inert set, nothing gets kicked out: g1 is
+a Given (and Wanteds don't rewrite Givens), and w2 doesn't mention the LHS
+of w2. We'll thus lose.
+
+But if w2 is swapped around, to
+
+    [W] w3 : F beta ~ F a
+
+then we'll kick w1 out of the inert
+set (it mentions the LHS of w3). We then rewrite w1 to
+
+    [W] w4 : UnF (F a) ~ beta
+
+and then, using g1, to
+
+    [W] w5 : a ~ beta
+
+at which point we can unify and go on to glory. (This rewriting actually
+happens all at once, in the call to rewrite during canonicalisation.)
+
+But what about the new LHS makes it better? It mentions a variable (beta)
+that can appear in a Wanted -- a touchable metavariable never appears
+in a Given. On the other hand, the original LHS mentioned only variables
+that appear in Givens. We thus choose to put variables that can appear
+in Wanteds on the left.
+
+Ticket #12526 is another good example of this in action.
+
+-}
+
+---------------------
+canEqCanLHS :: CtEvidence            -- ev :: lhs ~ rhs
+            -> EqRel -> SwapFlag
+            -> CanEqLHS              -- lhs (or, if swapped, rhs)
+            -> TcType                -- lhs: pretty lhs, already rewritten
+            -> TcType -> TcType      -- rhs: already rewritten
+            -> TcS (StopOrContinue Ct)
+canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
+  | k1 `tcEqType` k2
+  = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
+
+  | otherwise
+  = canEqCanLHSHetero ev eq_rel swapped lhs1 k1 xi2 k2
+
+  where
+    k1 = canEqLHSKind lhs1
+    k2 = typeKind xi2
+
+
+{-
+Note [Kind Equality Orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+While in theory [W] x ~ y and [W] y ~ x ought to give us the same behaviour, in practice it does not.
+See Note [Fundeps with instances, and equality orientation] where this is discussed at length.
+As a rule of thumb: we keep the newest unification variables on the left of the equality.
+See also Note [Improvement orientation] in GHC.Tc.Solver.Interact.
+
+In particular, `canEqCanLHSHetero` produces the following constraint equalities
+
+[X] (xi1 :: ki1) ~ (xi2 :: ki2)
+  -->  [X] kco :: ki1 ~ ki2
+       [X] co : xi1 :: ki1 ~ (xi2 |> sym kco) :: ki1
+
+Note that the types in the LHS of the new constraints are the ones that were on the LHS of
+the original constraint.
+
+--- Historical note ---
+We prevously used to flip the kco to avoid using a sym in the cast
+
+[X] (xi1 :: ki1) ~ (xi2 :: ki2)
+  -->  [X] kco :: ki2 ~ ki1
+       [X] co : xi1 :: ki1 ~ (xi2 |> kco) :: ki1
+
+But this sent solver in an infinite loop (see #19415).
+-- End of historical note --
+-}
+
+canEqCanLHSHetero :: CtEvidence         -- :: (xi1 :: ki1) ~ (xi2 :: ki2)
+                  -> EqRel -> SwapFlag
+                  -> CanEqLHS           -- xi1
+                  -> TcKind             -- ki1
+                  -> TcType             -- xi2
+                  -> TcKind             -- ki2
+                  -> TcS (StopOrContinue Ct)
+canEqCanLHSHetero ev eq_rel swapped lhs1 ki1 xi2 ki2
+  -- See Note [Equalities with incompatible kinds]
+  -- See Note [Kind Equality Orientation]
+  -- NB: preserve left-to-right orientation!!
+  -- See Note [Fundeps with instances, and equality orientation]
+  --     wrinkle (W2) in GHC.Tc.Solver.Interact
+  = do { (kind_ev, kind_co) <- mk_kind_eq   -- :: ki1 ~N ki2
+
+       ; let  -- kind_co :: (ki1 :: *) ~N (ki2 :: *)   (whether swapped or not)
+             lhs_redn = mkReflRedn role xi1
+             rhs_redn = mkGReflRightRedn role xi2 (mkSymCo kind_co)
+
+             -- See Note [Equalities with incompatible kinds], Wrinkle (1)
+             -- This will be ignored in rewriteEqEvidence if the work item is a Given
+             rewriters = rewriterSetFromCo kind_co
+
+       ; traceTcS "Hetero equality gives rise to kind equality"
+           (ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ])
+       ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn
+
+       ; emitWorkNC [type_ev]  -- delay the type equality until after we've finished
+                               -- the kind equality, which may unlock things
+                               -- See Note [Equalities with incompatible kinds]
+
+       ; solveNonCanonicalEquality kind_ev NomEq ki1 ki2 }
+  where
+    mk_kind_eq :: TcS (CtEvidence, CoercionN)
+    mk_kind_eq = case ev of
+      CtGiven { ctev_evar = evar }
+        -> do { let kind_co = maybe_sym $ mkKindCo (mkCoVarCo evar) -- :: k1 ~ k2
+              ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)
+              ; return (kind_ev, ctEvCoercion kind_ev) }
+
+      CtWanted { ctev_rewriters = rewriters }
+        -> newWantedEq kind_loc rewriters Nominal ki1 ki2
+
+    xi1      = canEqLHSType lhs1
+    loc      = ctev_loc ev
+    role     = eqRelRole eq_rel
+    kind_loc = mkKindLoc xi1 xi2 loc
+    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki1 ki2
+
+    maybe_sym = case swapped of
+          IsSwapped  -> mkSymCo         -- if the input is swapped, then we
+                                        -- will have k2 ~ k1, so flip it to k1 ~ k2
+          NotSwapped -> id
+
+-- guaranteed that typeKind lhs == typeKind rhs
+canEqCanLHSHomo :: CtEvidence
+                -> EqRel -> SwapFlag
+                -> CanEqLHS           -- lhs (or, if swapped, rhs)
+                -> TcType             -- pretty lhs
+                -> TcType -> TcType   -- rhs, pretty rhs
+                -> TcS (StopOrContinue Ct)
+canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
+  | (xi2', mco) <- split_cast_ty xi2
+  , Just lhs2 <- canEqLHS_maybe xi2'
+  = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkSymMCo mco) mco
+
+  | otherwise
+  = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2
+
+  where
+    split_cast_ty (CastTy ty co) = (ty, MCo co)
+    split_cast_ty other          = (other, MRefl)
+
+-- This function deals with the case that both LHS and RHS are potential
+-- CanEqLHSs.
+canEqCanLHS2 :: CtEvidence              -- lhs ~ (rhs |> mco)
+                                        -- or, if swapped: (rhs |> mco) ~ lhs
+             -> EqRel -> SwapFlag
+             -> CanEqLHS                -- lhs (or, if swapped, rhs)
+             -> TcType                  -- pretty lhs
+             -> CanEqLHS                -- rhs
+             -> TcType                  -- pretty rhs
+             -> MCoercion               -- :: kind(rhs) ~N kind(lhs)
+             -> TcS (StopOrContinue Ct)
+canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco
+  | lhs1 `eqCanEqLHS` lhs2
+    -- It must be the case that mco is reflexive
+  = canEqReflexive ev eq_rel (canEqLHSType lhs1)
+
+  | TyVarLHS tv1 <- lhs1
+  , TyVarLHS tv2 <- lhs2
+  , swapOverTyVars (isGiven ev) tv1 tv2
+  = do { traceTcS "canEqLHS2 swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)
+       ; new_ev <- do_swap
+       ; canEqCanLHSFinish new_ev eq_rel IsSwapped (TyVarLHS tv2)
+                                                   (ps_xi1 `mkCastTyMCo` sym_mco) }
+
+  | TyVarLHS tv1 <- lhs1
+  , TyFamLHS fun_tc2 fun_args2 <- lhs2
+  = canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco
+
+  | TyFamLHS fun_tc1 fun_args1 <- lhs1
+  , TyVarLHS tv2 <- lhs2
+  = do { new_ev <- do_swap
+       ; canEqTyVarFunEq new_ev eq_rel IsSwapped tv2 ps_xi2
+                                                 fun_tc1 fun_args1 ps_xi1 sym_mco }
+
+  | TyFamLHS fun_tc1 fun_args1 <- lhs1
+  , TyFamLHS fun_tc2 fun_args2 <- lhs2
+  -- See Note [Decomposing type family applications]
+  = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2)
+
+         -- emit wanted equalities for injective type families
+       ; let inj_eqns :: [TypeEqn]  -- TypeEqn = Pair Type
+             inj_eqns
+               | ReprEq <- eq_rel   = []   -- injectivity applies only for nom. eqs.
+               | fun_tc1 /= fun_tc2 = []   -- if the families don't match, stop.
+
+               | Injective inj <- tyConInjectivityInfo fun_tc1
+               = [ Pair arg1 arg2
+                 | (arg1, arg2, True) <- zip3 fun_args1 fun_args2 inj ]
+
+                 -- built-in synonym families don't have an entry point
+                 -- for this use case. So, we just use sfInteractInert
+                 -- and pass two equal RHSs. We *could* add another entry
+                 -- point, but then there would be a burden to make
+                 -- sure the new entry point and existing ones were
+                 -- internally consistent. This is slightly distasteful,
+                 -- but it works well in practice and localises the
+                 -- problem.
+               | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc1
+               = let ki1 = canEqLHSKind lhs1
+                     ki2 | MRefl <- mco
+                         = ki1   -- just a small optimisation
+                         | otherwise
+                         = canEqLHSKind lhs2
+
+                     fake_rhs1 = anyTypeOfKind ki1
+                     fake_rhs2 = anyTypeOfKind ki2
+                 in
+                 sfInteractInert ops fun_args1 fake_rhs1 fun_args2 fake_rhs2
+
+               | otherwise  -- ordinary, non-injective type family
+               = []
+
+       ; case ev of
+           CtWanted { ctev_rewriters = rewriters } ->
+             mapM_ (\ (Pair t1 t2) -> unifyWanted rewriters (ctEvLoc ev) Nominal t1 t2) inj_eqns
+           CtGiven {} -> return ()
+             -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Interact
+
+       ; tclvl <- getTcLevel
+       ; let tvs1 = tyCoVarsOfTypes fun_args1
+             tvs2 = tyCoVarsOfTypes fun_args2
+
+             swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 &&
+                          -- swap 'em: Note [Put touchable variables on the left]
+                                  not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1)
+                          -- this check is just to avoid unfruitful swapping
+
+               -- If we have F a ~ F (F a), we want to swap.
+             swap_for_occurs
+               | cterHasNoProblem   $ checkTyFamEq fun_tc2 fun_args2
+                                                   (mkTyConApp fun_tc1 fun_args1)
+               , cterHasOccursCheck $ checkTyFamEq fun_tc1 fun_args1
+                                                   (mkTyConApp fun_tc2 fun_args2)
+               = True
+
+               | otherwise
+               = False
+
+       ; if swap_for_rewriting || swap_for_occurs
+         then do { new_ev <- do_swap
+                 ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) }
+         else finish_without_swapping }
+
+  -- that's all the special cases. Now we just figure out which non-special case
+  -- to continue to.
+  | otherwise
+  = finish_without_swapping
+
+  where
+    sym_mco = mkSymMCo mco
+
+    do_swap = rewriteCastedEquality ev eq_rel swapped (canEqLHSType lhs1) (canEqLHSType lhs2) mco
+    finish_without_swapping = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco)
+
+
+-- This function handles the case where one side is a tyvar and the other is
+-- a type family application. Which to put on the left?
+--   If the tyvar is a touchable meta-tyvar, put it on the left, as this may
+--   be our only shot to unify.
+--   Otherwise, put the function on the left, because it's generally better to
+--   rewrite away function calls. This makes types smaller. And it seems necessary:
+--     [W] F alpha ~ alpha
+--     [W] F alpha ~ beta
+--     [W] G alpha beta ~ Int   ( where we have type instance G a a = a )
+--   If we end up with a stuck alpha ~ F alpha, we won't be able to solve this.
+--   Test case: indexed-types/should_compile/CEqCanOccursCheck
+canEqTyVarFunEq :: CtEvidence               -- :: lhs ~ (rhs |> mco)
+                                            -- or (rhs |> mco) ~ lhs if swapped
+                -> EqRel -> SwapFlag
+                -> TyVar -> TcType          -- lhs (or if swapped rhs), pretty lhs
+                -> TyCon -> [Xi] -> TcType  -- rhs (or if swapped lhs) fun and args, pretty rhs
+                -> MCoercion                -- :: kind(rhs) ~N kind(lhs)
+                -> TcS (StopOrContinue Ct)
+canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco
+  = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs
+       ; if | case is_touchable of { Untouchable -> False; _ -> True }
+            , cterHasNoProblem $
+                checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily
+            -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1) rhs
+
+            | otherwise
+              -> do { new_ev <- rewriteCastedEquality ev eq_rel swapped
+                                  (mkTyVarTy tv1) (mkTyConApp fun_tc2 fun_args2)
+                                  mco
+                    ; canEqCanLHSFinish new_ev eq_rel IsSwapped
+                                  (TyFamLHS fun_tc2 fun_args2)
+                                  (ps_xi1 `mkCastTyMCo` sym_mco) } }
+  where
+    sym_mco = mkSymMCo mco
+    rhs = ps_xi2 `mkCastTyMCo` mco
+
+-- The RHS here is either not CanEqLHS, or it's one that we
+-- want to rewrite the LHS to (as per e.g. swapOverTyVars)
+canEqCanLHSFinish :: CtEvidence
+                  -> EqRel -> SwapFlag
+                  -> CanEqLHS             -- lhs (or, if swapped, rhs)
+                  -> TcType               -- rhs (or, if swapped, lhs)
+                  -> TcS (StopOrContinue Ct)
+canEqCanLHSFinish ev eq_rel swapped lhs rhs
+    -- RHS is fully rewritten, but with type synonyms
+    --   preserved as much as possible
+    -- Guaranteed preconditions that
+    --    (TyEq:K)  handled in canEqCanLHSHomo
+    --    (TyEq:N)  checked in can_eq_nc'
+    --    (TyEq:TV) handled in canEqCanLHS2
+
+  = do { -- rewriteEqEvidence performs the swap if necessary
+         new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
+                                     (mkReflRedn role lhs_ty)
+                                     (mkReflRedn role rhs)
+
+       -- Assertion: (TyEq:K) is already satisfied
+       ; massert (canEqLHSKind lhs `eqType` typeKind rhs)
+
+       -- Assertion: (TyEq:N) is already satisfied (if applicable)
+       ; assertPprM ty_eq_N_OK $
+           vcat [ text "CanEqCanLHSFinish: (TyEq:N) not satisfied"
+                , text "rhs:" <+> ppr rhs ]
+
+       -- Do checkTypeEq to guarantee (TyEq:OC), (TyEq:F)
+       -- Must do the occurs check even on tyvar/tyvar equalities,
+       -- in case have  x ~ (y :: ..x...); this is #12593.
+       ; let result0 = checkTypeEq lhs rhs `cterRemoveProblem` cteTypeFamily
+                       -- cterRemoveProblem cteTypeFamily: type families are OK here
+                       -- NB: no occCheckExpand here; see Note [Rewriting synonyms]
+                       --     in GHC.Tc.Solver.Rewrite
+
+             -- (a ~R# b a) is soluble if b later turns out to be Identity
+             result = case eq_rel of
+                        NomEq  -> result0
+                        ReprEq -> cterSetOccursCheckSoluble result0
+
+             non_canonical_result what
+                = do { traceTcS ("canEqCanLHSFinish: " ++ what) (ppr lhs $$ ppr rhs)
+                     ; solveIrredEquality (NonCanonicalReason result) new_ev }
+
+       ; if cterHasNoProblem result
+         then do { traceTcS "CEqCan" (ppr lhs $$ ppr rhs)
+                 ; ics <- getInertCans
+                 ; interactEq ics (EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel
+                                        , eq_lhs = lhs, eq_rhs = rhs }) }
+
+         else do { m_stuff <- breakTyEqCycle_maybe ev result lhs rhs
+                           -- See Note [Type equality cycles];
+                           -- returning Nothing is the vastly common case
+                 ; case m_stuff of
+                     { Nothing -> non_canonical_result "Can't make canonical"
+
+
+                     ; Just rhs_redn@(Reduction _ new_rhs) ->
+              do { traceTcS "canEqCanLHSFinish breaking a cycle" $
+                      vcat [ text "lhs:" <+> ppr lhs, text "rhs:" <+> ppr rhs
+                           , text "new_rhs:" <+> ppr new_rhs ]
+
+                   -- This check is Detail (1) in the Note
+                 ; if cterHasOccursCheck (checkTypeEq lhs new_rhs)
+                   then non_canonical_result "Note [Type equality cycles] Detail (1)"
+
+                   else do { -- See Detail (6) of Note [Type equality cycles]
+                             new_new_ev <- rewriteEqEvidence emptyRewriterSet
+                                             new_ev NotSwapped
+                                             (mkReflRedn Nominal lhs_ty)
+                                             rhs_redn
+                           ; ics <- getInertCans
+                           ; interactEq ics (EqCt { eq_ev = new_new_ev, eq_eq_rel = eq_rel
+                                                  , eq_lhs = lhs, eq_rhs = new_rhs }) }}}}}
+  where
+    role = eqRelRole eq_rel
+
+    lhs_ty = canEqLHSType lhs
+
+    -- This is about (TyEq:N): check that we don't have a saturated application
+    -- of a newtype TyCon at the top level of the RHS, if the constructor
+    -- of the newtype is in scope.
+    ty_eq_N_OK :: TcS Bool
+    ty_eq_N_OK
+      | ReprEq <- eq_rel
+      , Just (tc, tc_args) <- splitTyConApp_maybe rhs
+      , Just con <- newTyConDataCon_maybe tc
+      -- #22310: only a problem if the newtype TyCon is saturated.
+      , tc_args `lengthAtLeast` tyConArity tc
+      -- #21010: only a problem if the newtype constructor is in scope.
+      = do { rdr_env <- getGlobalRdrEnvTcS
+           ; let con_in_scope = isJust $ lookupGRE_Name rdr_env (dataConName con)
+           ; return $ not con_in_scope }
+      | otherwise
+      = return True
+
+-- | Solve a reflexive equality constraint
+canEqReflexive :: CtEvidence    -- ty ~ ty
+               -> EqRel
+               -> TcType        -- ty
+               -> TcS (StopOrContinue Ct)   -- always Stop
+canEqReflexive ev eq_rel ty
+  = do { setEvBindIfWanted ev IsCoherent (evCoercion $ mkReflCo (eqRelRole eq_rel) ty)
+       ; stopWith ev "Solved by reflexivity" }
+
+{- Note [Equalities with incompatible kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What do we do when we have an equality
+
+  (tv :: k1) ~ (rhs :: k2)
+
+where k1 and k2 differ? Easy: we create a coercion that relates k1 and
+k2 and use this to cast. To wit, from
+
+  [X] (tv :: k1) ~ (rhs :: k2)
+
+(where [X] is [G] or [W]), we go to
+
+  [X] co :: k1 ~ k2
+  [X] (tv :: k1) ~ ((rhs |> sym co) :: k1)
+
+We carry on with the *kind equality*, not the type equality, because
+solving the former may unlock the latter. This choice is made in
+canEqCanLHSHetero. It is important: otherwise, T13135 loops.
+
+Wrinkles:
+
+ (1) When X is W, the new type-level wanted is effectively rewritten by the
+     kind-level one. We thus include the kind-level wanted in the RewriterSet
+     for the type-level one. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint.
+     This is done in canEqCanLHSHetero.
+
+ (2) If we have [W] w :: alpha ~ (rhs |> sym co_hole), should we unify alpha? No.
+     The problem is that the wanted w is effectively rewritten by another wanted,
+     and unifying alpha effectively promotes this wanted to a given. Doing so
+     means we lose track of the rewriter set associated with the wanted.
+
+     On the other hand, w is perfectly suitable for rewriting, because of the
+     way we carefully track rewriter sets.
+
+     We thus allow w to be a CEqCan, but we prevent unification. See
+     Note [Unification preconditions] in GHC.Tc.Utils.Unify.
+
+     The only tricky part is that we must later indeed unify if/when the kind-level
+     wanted gets solved. This is done in kickOutAfterFillingCoercionHole,
+     which kicks out all equalities whose RHS mentions the filled-in coercion hole.
+     Note that it looks for type family equalities, too, because of the use of
+     unifyTest in canEqTyVarFunEq.
+
+ (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the
+     algorithm detailed here, producing [W] co :: k1 ~ k2, and adding
+     [W] (a :: k1) ~ ((rhs |> sym co) :: k1) to the irreducibles. Some time
+     later, we solve co, and fill in co's coercion hole. This kicks out
+     the irreducible as described in (2).
+     But now, during canonicalization, we see the cast
+     and remove it, in canEqCast. By the time we get into canEqCanLHS, the equality
+     is heterogeneous again, and the process repeats.
+
+     To avoid this, we don't strip casts off a type if the other type
+     in the equality is a CanEqLHS (the scenario above can happen with a
+     type family, too. testcase: typecheck/should_compile/T13822).
+     And this is an improvement regardless:
+     because tyvars can, generally, unify with casted types, there's no
+     reason to go through the work of stripping off the cast when the
+     cast appears opposite a tyvar. This is implemented in the cast case
+     of can_eq_nc'.
+
+Historical note:
+
+We used to do this via emitting a Derived kind equality and then parking
+the heterogeneous equality as irreducible. But this new approach is much
+more direct. And it doesn't produce duplicate Deriveds (as the old one did).
+
+Note [Type synonyms and canonicalization]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We treat type synonym applications as xi types, that is, they do not
+count as type function applications.  However, we do need to be a bit
+careful with type synonyms: like type functions they may not be
+generative or injective.  However, unlike type functions, they are
+parametric, so there is no problem in expanding them whenever we see
+them, since we do not need to know anything about their arguments in
+order to expand them; this is what justifies not having to treat them
+as specially as type function applications.  The thing that causes
+some subtleties is that we prefer to leave type synonym applications
+*unexpanded* whenever possible, in order to generate better error
+messages.
+
+If we encounter an equality constraint with type synonym applications
+on both sides, or a type synonym application on one side and some sort
+of type application on the other, we simply must expand out the type
+synonyms in order to continue decomposing the equality constraint into
+primitive equality constraints.  For example, suppose we have
+
+  type F a = [Int]
+
+and we encounter the equality
+
+  F a ~ [b]
+
+In order to continue we must expand F a into [Int], giving us the
+equality
+
+  [Int] ~ [b]
+
+which we can then decompose into the more primitive equality
+constraint
+
+  Int ~ b.
+
+However, if we encounter an equality constraint with a type synonym
+application on one side and a variable on the other side, we should
+NOT (necessarily) expand the type synonym, since for the purpose of
+good error messages we want to leave type synonyms unexpanded as much
+as possible.  Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS.
+
+Note [Type equality cycles]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this situation (from indexed-types/should_compile/GivenLoop):
+
+  instance C (Maybe b)
+  *[G] a ~ Maybe (F a)
+  [W] C a
+
+or (typecheck/should_compile/T19682b):
+
+  instance C (a -> b)
+  *[W] alpha ~ (Arg alpha -> Res alpha)
+  [W] C alpha
+
+or (typecheck/should_compile/T21515):
+
+  type family Code a
+  *[G] Code a ~ '[ '[ Head (Head (Code a)) ] ]
+  [W] Code a ~ '[ '[ alpha ] ]
+
+In order to solve the final Wanted, we must use the starred constraint
+for rewriting. But note that all starred constraints have occurs-check failures,
+and so we can't straightforwardly add these to the inert set and
+use them for rewriting. (NB: A rigid type constructor is at the
+top of all RHSs, preventing reorienting in canEqTyVarFunEq in the tyvar
+cases.)
+
+The key idea is to replace the outermost type family applications in the RHS of the
+starred constraints with a fresh variable, which we'll call a cycle-breaker
+variable, or cbv. Then, relate the cbv back with the original type family application
+via new equality constraints. Our situations thus become:
+
+  instance C (Maybe b)
+  [G] a ~ Maybe cbv
+  [G] F a ~ cbv
+  [W] C a
+
+or
+
+  instance C (a -> b)
+  [W] alpha ~ (cbv1 -> cbv2)
+  [W] Arg alpha ~ cbv1
+  [W] Res alpha ~ cbv2
+  [W] C alpha
+
+or
+
+  [G] Code a ~ '[ '[ cbv ] ]
+  [G] Head (Head (Code a)) ~ cbv
+  [W] Code a ~ '[ '[ alpha ] ]
+
+This transformation (creating the new types and emitting new equality
+constraints) is done in breakTyEqCycle_maybe.
+
+The details depend on whether we're working with a Given or a Wanted.
+
+Given
+-----
+
+We emit a new Given, [G] F a ~ cbv, equating the type family application to
+our new cbv. Note its orientation: The type family ends up on the left; see
+commentary on canEqTyVarFunEq, which decides how to orient such cases. No
+special treatment for CycleBreakerTvs is necessary. This scenario is now
+easily soluble, by using the first Given to rewrite the Wanted, which can now
+be solved.
+
+(The first Given actually also rewrites the second one, giving
+[G] F (Maybe cbv) ~ cbv, but this causes no trouble.)
+
+Of course, we don't want our fresh variables leaking into e.g. error messages.
+So we fill in the metavariables with their original type family applications
+after we're done running the solver (in nestImplicTcS and runTcSWithEvBinds).
+This is done by restoreTyVarCycles, which uses the inert_cycle_breakers field in
+InertSet, which contains the pairings invented in breakTyEqCycle_maybe.
+
+That is:
+
+We transform
+  [G] g : lhs ~ ...(F lhs)...
+to
+  [G] (Refl lhs) : F lhs ~ cbv      -- CEqCan
+  [G] g          : lhs ~ ...cbv...  -- CEqCan
+
+Note that
+* `cbv` is a fresh cycle breaker variable.
+* `cbv` is a is a meta-tyvar, but it is completely untouchable.
+* We track the cycle-breaker variables in inert_cycle_breakers in InertSet
+* We eventually fill in the cycle-breakers, with `cbv := F lhs`.
+  No one else fills in cycle-breakers!
+* The evidence for the new `F lhs ~ cbv` constraint is Refl, because we know
+  this fill-in is ultimately going to happen.
+* In inert_cycle_breakers, we remember the (cbv, F lhs) pair; that is, we
+  remember the /original/ type.  The [G] F lhs ~ cbv constraint may be rewritten
+  by other givens (eg if we have another [G] lhs ~ (b,c)), but at the end we
+  still fill in with cbv := F lhs
+* This fill-in is done when solving is complete, by restoreTyVarCycles
+  in nestImplicTcS and runTcSWithEvBinds.
+
+Wanted
+------
+The fresh cycle-breaker variables here must actually be normal, touchable
+metavariables. That is, they are TauTvs. Nothing at all unusual. Repeating
+the example from above, we have
+
+  *[W] alpha ~ (Arg alpha -> Res alpha)
+
+and we turn this into
+
+  *[W] alpha ~ (cbv1 -> cbv2)
+  [W] Arg alpha ~ cbv1
+  [W] Res alpha ~ cbv2
+
+where cbv1 and cbv2 are fresh TauTvs. Why TauTvs? See [Why TauTvs] below.
+
+Critically, we emit the two new constraints (the last two above)
+directly instead of calling unifyWanted. (Otherwise, we'd end up unifying cbv1
+and cbv2 immediately, achieving nothing.)
+Next, we unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This
+unification -- which must be the next step after breaking the cycles --
+happens in the course of normal behavior of top-level
+interactions, later in the solver pipeline. We know this unification will
+indeed happen because breakTyEqCycle_maybe, which decides whether to apply
+this logic, checks to ensure unification will succeed in its final_check.
+(In particular, the LHS must be a touchable tyvar, never a type family. We don't
+yet have an example of where this logic is needed with a type family, and it's
+unclear how to handle this case, so we're skipping for now.) Now, we're
+here (including further context from our original example, from the top of the
+Note):
+
+  instance C (a -> b)
+  [W] Arg (cbv1 -> cbv2) ~ cbv1
+  [W] Res (cbv1 -> cbv2) ~ cbv2
+  [W] C (cbv1 -> cbv2)
+
+The first two W constraints reduce to reflexivity and are discarded,
+and the last is easily soluble.
+
+[Why TauTvs]:
+Let's look at another example (typecheck/should_compile/T19682) where we need
+to unify the cbvs:
+
+  class    (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys
+  instance (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys
+
+  type family SameShapeAs xs ys :: Constraint where
+    SameShapeAs '[] ys      = (ys ~ '[])
+    SameShapeAs (x : xs) ys = (ys ~ (Head ys : Tail ys))
+
+  type family AllEqF xs ys :: Constraint where
+    AllEqF '[]      '[]      = ()
+    AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys)
+
+  [W] alpha ~ (Head alpha : Tail alpha)
+  [W] AllEqF '[Bool] alpha
+
+Without the logic detailed in this Note, we're stuck here, as AllEqF cannot
+reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach,
+just as described above. We thus invent cbv1 and cbv2 and unify
+alpha := cbv1 -> cbv2, yielding (after zonking)
+
+  [W] Head (cbv1 : cbv2) ~ cbv1
+  [W] Tail (cbv1 : cbv2) ~ cbv2
+  [W] AllEqF '[Bool] (cbv1 : cbv2)
+
+The first two W constraints simplify to reflexivity and are discarded.
+But the last reduces:
+
+  [W] Bool ~ cbv1
+  [W] AllEq '[] cbv2
+
+The first of these is solved by unification: cbv1 := Bool. The second
+is solved by the instance for AllEq to become
+
+  [W] AllEqF '[] cbv2
+  [W] SameShapeAs '[] cbv2
+
+While the first of these is stuck, the second makes progress, to lead to
+
+  [W] AllEqF '[] cbv2
+  [W] cbv2 ~ '[]
+
+This second constraint is solved by unification: cbv2 := '[]. We now
+have
+
+  [W] AllEqF '[] '[]
+
+which reduces to
+
+  [W] ()
+
+which is trivially satisfiable. Hooray!
+
+Note that we need to unify the cbvs here; if we did not, there would be
+no way to solve those constraints. That's why the cycle-breakers are
+ordinary TauTvs.
+
+In all cases
+------------
+
+We detect this scenario by the following characteristics:
+ - a constraint with a soluble occurs-check failure
+   (as indicated by the cteSolubleOccurs bit set in a CheckTyEqResult
+   from checkTypeEq)
+ - and a nominal equality
+ - and either
+    - a Given flavour (but see also Detail (7) below)
+    - a Wanted flavour, with a touchable metavariable on the left
+
+We don't use this trick for representational equalities, as there is no
+concrete use case where it is helpful (unlike for nominal equalities).
+Furthermore, because function applications can be CanEqLHSs, but newtype
+applications cannot, the disparities between the cases are enough that it
+would be effortful to expand the idea to representational equalities. A quick
+attempt, with
+
+      data family N a b
+
+      f :: (Coercible a (N a b), Coercible (N a b) b) => a -> b
+      f = coerce
+
+failed with "Could not match 'b' with 'b'." Further work is held off
+until when we have a concrete incentive to explore this dark corner.
+
+Details:
+
+ (1) We don't look under foralls, at all, when substituting away type family
+     applications, because doing so can never be fruitful. Recall that we
+     are in a case like [G] lhs ~ forall b. ... lhs ....   Until we have a type
+     family that can pull the body out from a forall (e.g. type instance F (forall b. ty) = ty),
+     this will always be
+     insoluble. Note also that the forall cannot be in an argument to a
+     type family, or that outer type family application would already have
+     been substituted away.
+
+     However, we still must check to make sure that breakTyEqCycle_maybe actually
+     succeeds in getting rid of all occurrences of the offending lhs. If
+     one is hidden under a forall, this won't be true. A similar problem can
+     happen if the variable appears only in a kind
+     (e.g. k ~ ... (a :: k) ...). So we perform an additional check after
+     performing the substitution. It is tiresome to re-run all of checkTypeEq
+     here, but reimplementing just the occurs-check is even more tiresome.
+
+     Skipping this check causes typecheck/should_fail/GivenForallLoop and
+     polykinds/T18451 to loop.
+
+ (2) Our goal here is to avoid loops in rewriting. We can thus skip looking
+     in coercions, as we don't rewrite in coercions in the algorithm in
+     GHC.Solver.Rewrite. (This is another reason
+     we need to re-check that we've gotten rid of all occurrences of the
+     offending variable.)
+
+ (3) As we're substituting as described in this Note, we can build ill-kinded
+     types. For example, if we have Proxy (F a) b, where (b :: F a), then
+     replacing this with Proxy cbv b is ill-kinded. However, we will later
+     set cbv := F a, and so the zonked type will be well-kinded again.
+     The temporary ill-kinded type hurts no one, and avoiding this would
+     be quite painfully difficult.
+
+     Specifically, this detail does not contravene the Purely Kinded Type Invariant
+     (Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType).
+     The PKTI says that we can call typeKind on any type, without failure.
+     It would be violated if we, say, replaced a kind (a -> b) with a kind c,
+     because an arrow kind might be consulted in piResultTys. Here, we are
+     replacing one opaque type like (F a b c) with another, cbv (opaque in
+     that we never assume anything about its structure, like that it has a
+     result type or a RuntimeRep argument).
+
+ (4) The evidence for the produced Givens is all just reflexive, because
+     we will eventually set the cycle-breaker variable to be the type family,
+     and then, after the zonk, all will be well. See also the notes at the
+     end of the Given section of this Note.
+
+ (5) The approach here is inefficient because it replaces every (outermost)
+     type family application with a type variable, regardless of whether that
+     particular appplication is implicated in the occurs check.  An alternative
+     would be to replce only type-family applications that mention the offending LHS.
+     For instance, we could choose to
+     affect only type family applications that mention the offending LHS:
+     e.g. in a ~ (F b, G a), we need to replace only G a, not F b. Furthermore,
+     we could try to detect cases like a ~ (F a, F a) and use the same
+     tyvar to replace F a. (Cf.
+     Note [Flattening type-family applications when matching instances]
+     in GHC.Core.Unify, which
+     goes to this extra effort.) There may be other opportunities for
+     improvement. However, this is really a very small corner case.
+     The investment to craft a clever,
+     performant solution seems unworthwhile.
+
+ (6) We often get the predicate associated with a constraint from its
+     evidence with ctPred. We thus must not only make sure the generated
+     CEqCan's fields have the updated RHS type (that is, the one produced
+     by replacing type family applications with fresh variables),
+     but we must also update the evidence itself. This is done by the call to rewriteEqEvidence
+     in canEqCanLHSFinish.
+
+ (7) We don't wish to apply this magic on the equalities created
+     by this very same process.
+     Consider this, from typecheck/should_compile/ContextStack2:
+
+       type instance TF (a, b) = (TF a, TF b)
+       t :: (a ~ TF (a, Int)) => ...
+
+       [G] a ~ TF (a, Int)
+
+     The RHS reduces, so we get
+
+       [G] a ~ (TF a, TF Int)
+
+     We then break cycles, to get
+
+       [G] g1 :: a ~ (cbv1, cbv2)
+       [G] g2 :: TF a ~ cbv1
+       [G] g3 :: TF Int ~ cbv2
+
+     g1 gets added to the inert set, as written. But then g2 becomes
+     the work item. g1 rewrites g2 to become
+
+       [G] TF (cbv1, cbv2) ~ cbv1
+
+     which then uses the type instance to become
+
+       [G] (TF cbv1, TF cbv2) ~ cbv1
+
+     which looks remarkably like the Given we started with. If left
+     unchecked, this will end up breaking cycles again, looping ad
+     infinitum (and resulting in a context-stack reduction error,
+     not an outright loop). The solution is easy: don't break cycles
+     on an equality generated by breaking cycles. Instead, we mark this
+     final Given as a CIrredCan with a NonCanonicalReason with the soluble
+     occurs-check bit set (only).
+
+     We track these equalities by giving them a special CtOrigin,
+     CycleBreakerOrigin. This works for both Givens and Wanteds, as
+     we need the logic in the W case for e.g. typecheck/should_fail/T17139.
+     Because this logic needs to work for Wanteds, too, we cannot
+     simply look for a CycleBreakerTv on the left: Wanteds don't use them.
+
+ (8) We really want to do this all only when there is a soluble occurs-check
+     failure, not when other problems arise (such as an impredicative
+     equality like alpha ~ forall a. a -> a). That is why breakTyEqCycle_maybe
+     uses cterHasOnlyProblem when looking at the result of checkTypeEq, which
+     checks for many of the invariants on a CEqCan.
+
+
+**********************************************************************
+*                                                                    *
+                   Rewriting evidence
+*                                                                    *
+**********************************************************************
+-}
+
+rewriteCastedEquality :: CtEvidence     -- :: lhs ~ (rhs |> mco), or (rhs |> mco) ~ lhs
+                      -> EqRel -> SwapFlag
+                      -> TcType         -- lhs
+                      -> TcType         -- rhs
+                      -> MCoercion      -- mco
+                      -> TcS CtEvidence -- :: (lhs |> sym mco) ~ rhs
+                                        -- result is independent of SwapFlag
+rewriteCastedEquality ev eq_rel swapped lhs rhs mco
+  = rewriteEqEvidence emptyRewriterSet ev swapped lhs_redn rhs_redn
+  where
+    lhs_redn = mkGReflRightMRedn role lhs sym_mco
+    rhs_redn = mkGReflLeftMRedn  role rhs mco
+
+    sym_mco = mkSymMCo mco
+    role    = eqRelRole eq_rel
+
+rewriteEqEvidence :: RewriterSet        -- New rewriters
+                                        -- See GHC.Tc.Types.Constraint
+                                        -- Note [Wanteds rewrite Wanteds]
+                  -> CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)
+                                        --              or orhs ~ olhs (swapped)
+                  -> SwapFlag
+                  -> Reduction          -- lhs_co :: olhs ~ nlhs
+                  -> Reduction          -- rhs_co :: orhs ~ nrhs
+                  -> TcS CtEvidence     -- Of type nlhs ~ nrhs
+-- With reductions (Reduction lhs_co nlhs) (Reduction rhs_co nrhs),
+-- rewriteEqEvidence yields, for a given equality (Given g olhs orhs):
+-- If not swapped
+--      g1 : nlhs ~ nrhs = sym lhs_co ; g ; rhs_co
+-- If swapped
+--      g1 : nlhs ~ nrhs = sym lhs_co ; Sym g ; rhs_co
+--
+-- For a wanted equality (Wanted w), we do the dual thing:
+-- New  w1 : nlhs ~ nrhs
+-- If not swapped
+--      w : olhs ~ orhs = lhs_co ; w1 ; sym rhs_co
+-- If swapped
+--      w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co
+--
+-- It's all a form of rewriteEvidence, specialised for equalities
+rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs)
+  | NotSwapped <- swapped
+  , isReflCo lhs_co      -- See Note [Rewriting with Refl]
+  , isReflCo rhs_co
+  = return (setCtEvPredType old_ev new_pred)
+
+  | CtGiven { ctev_evar = old_evar } <- old_ev
+  = do { let new_tm = evCoercion ( mkSymCo lhs_co
+                                  `mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar)
+                                  `mkTransCo` rhs_co)
+       ; newGivenEvVar loc (new_pred, new_tm) }
+
+  | CtWanted { ctev_dest = dest
+             , ctev_rewriters = rewriters } <- old_ev
+  , let rewriters' = rewriters S.<> new_rewriters
+  = do { (new_ev, hole_co) <- newWantedEq loc rewriters'
+                                          (ctEvRole old_ev) nlhs nrhs
+       ; let co = maybeSymCo swapped $
+                  lhs_co
+                  `mkTransCo` hole_co
+                  `mkTransCo` mkSymCo rhs_co
+       ; setWantedEq dest co
+       ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev
+                                            , ppr nlhs
+                                            , ppr nrhs
+                                            , ppr co
+                                            , ppr new_rewriters ])
+       ; return new_ev }
+
+#if __GLASGOW_HASKELL__ <= 810
+  | otherwise
+  = panic "rewriteEvidence"
+#endif
+  where
+    new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs
+    loc      = ctEvLoc old_ev
+
+{-
+**********************************************************************
+*                                                                    *
+                   interactEq
+*                                                                    *
+**********************************************************************
+
+Note [Combining equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   Inert:     g1 :: a ~ t
+   Work item: g2 :: a ~ t
+
+Then we can simply solve g2 from g1, thus g2 := g1.  Easy!
+But it's not so simple:
+
+* If t is a type variable, the equalties might be oriented differently:
+      e.g. (g1 :: a~b) and (g2 :: b~a)
+  So we look both ways round.  Hence the SwapFlag result to
+  inertsCanDischarge.
+
+* We can only do g2 := g1 if g1 can discharge g2; that depends on
+  (a) the role and (b) the flavour.  E.g. a representational equality
+  cannot discharge a nominal one; a Wanted cannot discharge a Given.
+  The predicate is eqCanRewriteFR.
+
+* Visibility. Suppose  S :: forall k. k -> Type, and consider unifying
+      S @Type (a::Type)  ~   S @(Type->Type) (b::Type->Type)
+  From the first argument we get (Type ~ Type->Type); from the second
+  argument we get (a ~ b) which in turn gives (Type ~ Type->Type).
+  See typecheck/should_fail/T16204c.
+
+  That first argument is invisible in the source program (aside from
+  visible type application), so we'd much prefer to get the error from
+  the second. We track visibility in the uo_visible field of a TypeEqOrigin.
+  We use this to prioritise visible errors (see GHC.Tc.Errors.tryReporters,
+  the partition on isVisibleOrigin).
+
+  So when combining two otherwise-identical equalites, we want to
+  keep the visible one, and discharge the invisible one.  Hence the
+  call to strictly_more_visible.
+-}
+
+interactEq :: InertCans -> EqCt -> TcS (StopOrContinue Ct)
+interactEq inerts
+  work_item@(EqCt { eq_lhs = lhs, eq_ev = ev, eq_eq_rel = eq_rel })
+
+  | Just (ev_i, swapped) <- inertsCanDischarge inerts work_item
+  = do { setEvBindIfWanted ev IsCoherent $
+         evCoercion (maybeSymCo swapped $
+                     downgradeRole (eqRelRole eq_rel)
+                                   (ctEvRole ev_i)
+                                   (ctEvCoercion ev_i))
+       ; stopWith ev "Solved from inert" }
+
+  | otherwise
+  = case lhs of
+       TyVarLHS tv -> tryToSolveByUnification tv work_item
+
+       TyFamLHS tc args -> do { improveLocalFunEqs inerts tc args work_item
+                              ; improveTopFunEqs tc args work_item
+                              ; finishEqCt work_item }
+
+
+inertsCanDischarge :: InertCans -> EqCt
+                   -> Maybe ( CtEvidence  -- The evidence for the inert
+                            , SwapFlag )  -- Whether we need mkSymCo
+inertsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w
+                                , eq_ev = ev_w, eq_eq_rel = eq_rel })
+  | (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i
+                                , eq_eq_rel = eq_rel }
+                                  <- findEq inerts lhs_w
+                         , rhs_i `tcEqType` rhs_w
+                         , inert_beats_wanted ev_i eq_rel ]
+  =  -- Inert:     a ~ ty
+     -- Work item: a ~ ty
+    Just (ev_i, NotSwapped)
+
+  | Just rhs_lhs <- canEqLHS_maybe rhs_w
+  , (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i
+                                , eq_eq_rel = eq_rel }
+                             <- findEq inerts rhs_lhs
+                         , rhs_i `tcEqType` canEqLHSType lhs_w
+                         , inert_beats_wanted ev_i eq_rel ]
+  =  -- Inert:     a ~ b
+     -- Work item: b ~ a
+     Just (ev_i, IsSwapped)
+
+  where
+    loc_w  = ctEvLoc ev_w
+    flav_w = ctEvFlavour ev_w
+    fr_w   = (flav_w, eq_rel)
+
+    inert_beats_wanted ev_i eq_rel
+      = -- eqCanRewriteFR:        see second bullet of Note [Combining equalities]
+        -- strictly_more_visible: see last bullet of Note [Combining equalities]
+        fr_i `eqCanRewriteFR` fr_w
+        && not ((loc_w `strictly_more_visible` ctEvLoc ev_i)
+                 && (fr_w `eqCanRewriteFR` fr_i))
+      where
+        fr_i = (ctEvFlavour ev_i, eq_rel)
+
+    -- See Note [Combining equalities], final bullet
+    strictly_more_visible loc1 loc2
+       = not (isVisibleOrigin (ctLocOrigin loc2)) &&
+         isVisibleOrigin (ctLocOrigin loc1)
+
+inertsCanDischarge _ _ = Nothing
+
+
+----------------------
+-- We have a meta-tyvar on the left, and metaTyVarUpdateOK has said "yes"
+-- So try to solve by unifying.
+-- Three reasons why not:
+--    Skolem escape
+--    Given equalities (GADTs)
+--    Unifying a TyVarTv with a non-tyvar type
+tryToSolveByUnification :: TcTyVar   -- LHS tyvar
+                        -> EqCt
+                        -> TcS (StopOrContinue Ct)
+tryToSolveByUnification tv
+  work_item@(EqCt { eq_rhs = rhs, eq_ev = ev, eq_eq_rel = eq_rel })
+
+  | ReprEq <- eq_rel   -- See Note [Do not unify representational equalities]
+  = do { traceTcS "Not unifying representational equality" (ppr work_item)
+       ; dont_unify }
+
+  | otherwise
+  = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv rhs
+       ; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs
+                                                  , ppr is_touchable ])
+
+       ; case is_touchable of
+           Untouchable -> dont_unify
+           -- For the latter two cases see Note [Solve by unification]
+
+           TouchableSameLevel -> solveByUnification ev tv rhs
+
+           TouchableOuterLevel free_metas tv_lvl
+             -> do { wrapTcS $ mapM_ (promoteMetaTyVarTo tv_lvl) free_metas
+                   ; setUnificationFlag tv_lvl
+                   ; solveByUnification ev tv rhs } }
+  where
+    dont_unify = finishEqCt work_item
+
+solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS (StopOrContinue Ct)
+-- Solve with the identity coercion
+-- Precondition: kind(xi) equals kind(tv)
+-- Precondition: CtEvidence is Wanted
+-- Precondition: CtEvidence is nominal
+-- Returns: work_item where
+--        work_item = the new Given constraint
+--
+-- NB: No need for an occurs check here, because solveByUnification always
+--     arises from a CEqCan, a *canonical* constraint.  Its invariant (TyEq:OC)
+--     says that in (a ~ xi), the type variable a does not appear in xi.
+--     See GHC.Tc.Types.Constraint.Ct invariants.
+--
+-- Post: tv is unified (by side effect) with xi;
+--       we often write tv := xi
+solveByUnification ev tv xi
+  = do { let tv_ty = mkTyVarTy tv
+       ; traceTcS "Sneaky unification:" $
+                       vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi,
+                             text "Coercion:" <+> pprEq tv_ty xi,
+                             text "Left Kind is:" <+> ppr (typeKind tv_ty),
+                             text "Right Kind is:" <+> ppr (typeKind xi) ]
+       ; unifyTyVar tv xi
+       ; setEvBindIfWanted ev IsCoherent (evCoercion (mkNomReflCo xi))
+       ; n_kicked <- kickOutAfterUnification tv
+       ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) }
+
+{- Note [Avoid double unifications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The spontaneous solver has to return a given which mentions the unified unification
+variable *on the left* of the equality. Here is what happens if not:
+  Original wanted:  (a ~ alpha),  (alpha ~ Int)
+We spontaneously solve the first wanted, without changing the order!
+      given : a ~ alpha      [having unified alpha := a]
+Now the second wanted comes along, but it cannot rewrite the given, so we simply continue.
+At the end we spontaneously solve that guy, *reunifying*  [alpha := Int]
+
+We avoid this problem by orienting the resulting given so that the unification
+variable is on the left (note that alternatively we could attempt to
+enforce this at canonicalization).
+
+Note [Do not unify representational equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider   [W] alpha ~R# b
+where alpha is touchable. Should we unify alpha := b?
+
+Certainly not!  Unifying forces alpha and be to be the same; but they
+only need to be representationally equal types.
+
+For example, we might have another constraint [W] alpha ~# N b
+where
+  newtype N b = MkN b
+and we want to get alpha := N b.
+
+See also #15144, which was caused by unifying a representational
+equality.
+
+Note [Solve by unification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we solve
+   alpha[n] ~ ty
+by unification, there are two cases to consider
+
+* TouchableSameLevel: if the ambient level is 'n', then
+  we can simply update alpha := ty, and do nothing else
+
+* TouchableOuterLevel free_metas n: if the ambient level is greater than
+  'n' (the level of alpha), in addition to setting alpha := ty we must
+  do two other things:
+
+  1. Promote all the free meta-vars of 'ty' to level n.  After all,
+     alpha[n] is at level n, and so if we set, say,
+          alpha[n] := Maybe beta[m],
+     we must ensure that when unifying beta we do skolem-escape checks
+     etc relevant to level n.  Simple way to do that: promote beta to
+     level n.
+
+  2. Set the Unification Level Flag to record that a level-n unification has
+     taken place. See Note [The Unification Level Flag] in GHC.Tc.Solver.Monad
+
+NB: TouchableSameLevel is just an optimisation for TouchableOuterLevel. Promotion
+would be a no-op, and setting the unification flag unnecessarily would just
+make the solver iterate more often.  (We don't need to iterate when unifying
+at the ambient level because of the kick-out mechanism.)
+-}
+
+{-********************************************************************
+*                                                                    *
+          Final wrap-up for equalities
+*                                                                    *
+********************************************************************-}
+
+{- Note [Looking up primitive equalities in quantified constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For equalities (a ~# b) look up (a ~ b), and then do a superclass
+selection. This avoids having to support quantified constraints whose
+kind is not Constraint, such as (forall a. F a ~# b)
+
+See
+ * Note [Evidence for quantified constraints] in GHC.Core.Predicate
+ * Note [Equality superclasses in quantified constraints]
+   in GHC.Tc.Solver.Canonical
+-}
+
+--------------------
+solveIrredEquality :: CtIrredReason -> CtEvidence -> TcS (StopOrContinue Ct)
+solveIrredEquality reason ev
+  | EqPred eq_rel t1 t2 <- classifyPredType (ctEvPred ev)
+  = final_qci_check (mkIrredCt reason ev) eq_rel t1 t2
+    -- If the final_qci_check fails, we'll do continueWith on an IrredCt
+    -- That in turn will go down the Irred pipeline, so which deals with
+    -- the case where we have [G] Coercible (m a) (m b), and [W] m a ~R# m b
+    -- When we de-pipeline Irreds we may have to adjust here
+
+  | otherwise  -- All the calls come from in this module, where we deal
+               -- only with equalities, so ctEvPred ev) must be an equality.
+               -- Indeed, we could pass eq_rel, t1, t2 as arguments, to avoid
+               -- this can't happen case, but it's not a hot path, and this is
+               -- simple and robust
+  = pprPanic "solveIrredEquality" (ppr ev)
+
+--------------------
+finishEqCt :: EqCt -> TcS (StopOrContinue Ct)
+finishEqCt work_item@(EqCt { eq_lhs = lhs, eq_rhs = rhs, eq_eq_rel = eq_rel })
+  = final_qci_check (CEqCan work_item) eq_rel (canEqLHSType lhs) rhs
+
+--------------------
+final_qci_check :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct)
+-- The "final QCI check" checks to see if we have
+--    [W] t1 ~# t2
+-- and a Given quantified contraint like (forall a b. blah => a :~: b)
+-- Why?  See Note [Looking up primitive equalities in quantified constraints]
+final_qci_check work_ct eq_rel lhs rhs
+  | isWanted ev
+  , Just (cls, tys) <- boxEqPred eq_rel lhs rhs
+  = do { res <- matchLocalInst (mkClassPred cls tys) loc
+       ; case res of
+           OneInst { cir_mk_ev = mk_ev }
+             -> chooseInstance work_ct
+                    (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })
+           _ -> continueWith work_ct }
+
+  | otherwise
+  = continueWith work_ct
+  where
+    ev  = ctEvidence work_ct
+    loc = ctEvLoc ev
+
+    mk_eq_ev cls tys mk_ev evs
+      | sc_id : rest <- classSCSelIds cls  -- Just one superclass for this
+      = assert (null rest) $ case (mk_ev evs) of
+          EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e)
+          ev       -> pprPanic "mk_eq_ev" (ppr ev)
+      | otherwise = pprPanic "finishEqCt" (ppr work_ct)
+
+{-
+**********************************************************************
+*                                                                    *
+    Functional dependencies for type families
+*                                                                    *
+**********************************************************************
+
+Note [Reverse order of fundep equations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this scenario (from dependent/should_fail/T13135_simple):
+
+  type Sig :: Type -> Type
+  data Sig a = SigFun a (Sig a)
+
+  type SmartFun :: forall (t :: Type). Sig t -> Type
+  type family SmartFun sig = r | r -> sig where
+    SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig
+
+  [W] SmartFun @kappa sigma ~ (Int -> Bool)
+
+The injectivity of SmartFun allows us to produce two new equalities:
+
+  [W] w1 :: Type ~ kappa
+  [W] w2 :: SigFun @Type Int beta ~ sigma
+
+for some fresh (beta :: SigType). The second Wanted here is actually
+heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa.
+Of course, if we solve the first wanted first, the second becomes homogeneous.
+
+When looking for injectivity-inspired equalities, we work left-to-right,
+producing the two equalities in the order written above. However, these
+equalities are then passed into unifyWanted, which will fail, adding these
+to the work list. However, crucially, the work list operates like a *stack*.
+So, because we add w1 and then w2, we process w2 first. This is silly: solving
+w1 would unlock w2. So we make sure to add equalities to the work
+list in left-to-right order, which requires a few key calls to 'reverse'.
+
+This treatment is also used for class-based functional dependencies, although
+we do not have a program yet known to exhibit a loop there. It just seems
+like the right thing to do.
+
+When this was originally conceived, it was necessary to avoid a loop in T13135.
+That loop is now avoided by continuing with the kind equality (not the type
+equality) in canEqCanLHSHetero (see Note [Equalities with incompatible kinds]
+in GHC.Tc.Solver.Canonical). However, the idea of working left-to-right still
+seems worthwhile, and so the calls to 'reverse' remain.
+
+Note [Improvement orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also Note [Fundeps with instances, and equality orientation], which describes
+the Exact Same Problem, with the same solution, but for functional dependencies.
+
+A very delicate point is the orientation of equalities
+arising from injectivity improvement (#12522).  Suppose we have
+  type family F x = t | t -> x
+  type instance F (a, Int) = (Int, G a)
+where G is injective; and wanted constraints
+
+  [W] TF (alpha, beta) ~ fuv
+  [W] fuv ~ (Int, <some type>)
+
+The injectivity will give rise to constraints
+
+  [W] gamma1 ~ alpha
+  [W] Int ~ beta
+
+The fresh unification variable gamma1 comes from the fact that we
+can only do "partial improvement" here; see Section 5.2 of
+"Injective type families for Haskell" (HS'15).
+
+Now, it's very important to orient the equations this way round,
+so that the fresh unification variable will be eliminated in
+favour of alpha.  If we instead had
+   [W] alpha ~ gamma1
+then we would unify alpha := gamma1; and kick out the wanted
+constraint.  But when we grough it back in, it'd look like
+   [W] TF (gamma1, beta) ~ fuv
+and exactly the same thing would happen again!  Infinite loop.
+
+This all seems fragile, and it might seem more robust to avoid
+introducing gamma1 in the first place, in the case where the
+actual argument (alpha, beta) partly matches the improvement
+template.  But that's a bit tricky, esp when we remember that the
+kinds much match too; so it's easier to let the normal machinery
+handle it.  Instead we are careful to orient the new
+equality with the template on the left.  Delicate, but it works.
+
+-}
+
+--------------------
+improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> TcS ()
+-- See Note [FunDep and implicit parameter reactions]
+improveTopFunEqs fam_tc args (EqCt { eq_ev = ev, eq_rhs = rhs })
+
+  | isGiven ev = return ()  -- See Note [No Given/Given fundeps]
+
+  | otherwise
+  = do { fam_envs <- getFamInstEnvs
+       ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs
+       ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs
+                                          , ppr eqns ])
+       ; mapM_ (\(Pair ty1 ty2) -> unifyWanted rewriters loc Nominal ty1 ty2)
+               (reverse eqns) }
+         -- Missing that `reverse` causes T13135 and T13135_simple to loop.
+         -- See Note [Reverse order of fundep equations]
+
+  where
+    loc = bumpCtLocDepth (ctEvLoc ev)
+        -- ToDo: this location is wrong; it should be FunDepOrigin2
+        -- See #14778
+    rewriters = ctEvRewriters ev
+
+improve_top_fun_eqs :: FamInstEnvs
+                    -> TyCon -> [TcType] -> TcType
+                    -> TcS [TypeEqn]
+improve_top_fun_eqs fam_envs fam_tc args rhs_ty
+  | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+  = return (sfInteractTop ops args rhs_ty)
+
+  -- see Note [Type inference for type families with injectivity]
+  | isOpenTypeFamilyTyCon fam_tc
+  , Injective injective_args <- tyConInjectivityInfo fam_tc
+  , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc
+  = -- it is possible to have several compatible equations in an open type
+    -- family but we only want to derive equalities from one such equation.
+    do { let improvs = buildImprovementData fam_insts
+                           fi_tvs fi_tys fi_rhs (const Nothing)
+
+       ; traceTcS "improve_top_fun_eqs2" (ppr improvs)
+       ; concatMapM (injImproveEqns injective_args) $
+         take 1 improvs }
+
+  | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc
+  , Injective injective_args <- tyConInjectivityInfo fam_tc
+  = concatMapM (injImproveEqns injective_args) $
+    buildImprovementData (fromBranches (co_ax_branches ax))
+                         cab_tvs cab_lhs cab_rhs Just
+
+  | otherwise
+  = return []
+
+  where
+      in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty)
+
+      buildImprovementData
+          :: [a]                     -- axioms for a TF (FamInst or CoAxBranch)
+          -> (a -> [TyVar])          -- get bound tyvars of an axiom
+          -> (a -> [Type])           -- get LHS of an axiom
+          -> (a -> Type)             -- get RHS of an axiom
+          -> (a -> Maybe CoAxBranch) -- Just => apartness check required
+          -> [( [Type], Subst, [TyVar], Maybe CoAxBranch )]
+             -- Result:
+             -- ( [arguments of a matching axiom]
+             -- , RHS-unifying substitution
+             -- , axiom variables without substitution
+             -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] )
+      buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap =
+          [ (ax_args, subst, unsubstTvs, wrap axiom)
+          | axiom <- axioms
+          , let ax_args = axiomLHS axiom
+                ax_rhs  = axiomRHS axiom
+                ax_tvs  = axiomTVs axiom
+                in_scope1 = in_scope `extendInScopeSetList` ax_tvs
+          , Just subst <- [tcUnifyTyWithTFs False in_scope1 ax_rhs rhs_ty]
+          , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst)
+                unsubstTvs    = filter (notInSubst <&&> isTyVar) ax_tvs ]
+                   -- The order of unsubstTvs is important; it must be
+                   -- in telescope order e.g. (k:*) (a:k)
+
+      injImproveEqns :: [Bool]
+                     -> ([Type], Subst, [TyCoVar], Maybe CoAxBranch)
+                     -> TcS [TypeEqn]
+      injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr)
+        = do { subst <- instFlexiX subst unsubstTvs
+                  -- If the current substitution bind [k -> *], and
+                  -- one of the un-substituted tyvars is (a::k), we'd better
+                  -- be sure to apply the current substitution to a's kind.
+                  -- Hence instFlexiX.   #13135 was an example.
+
+             ; return [ Pair (substTy subst ax_arg) arg
+                        -- NB: the ax_arg part is on the left
+                        -- see Note [Improvement orientation]
+                      | case cabr of
+                          Just cabr' -> apartnessCheck (substTys subst ax_args) cabr'
+                          _          -> True
+                      , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] }
+
+
+improveLocalFunEqs :: InertCans -> TyCon -> [TcType] -> EqCt -> TcS ()
+-- Generate improvement equalities, by comparing
+-- the current work item with inert CFunEqs
+-- E.g.   x + y ~ z,   x + y' ~ z   =>   [W] y ~ y'
+--
+-- See Note [FunDep and implicit parameter reactions]
+improveLocalFunEqs inerts fam_tc args (EqCt { eq_ev = work_ev, eq_rhs = rhs })
+  = unless (null improvement_eqns) $
+    do { traceTcS "interactFunEq improvements: " $
+                   vcat [ text "Eqns:" <+> ppr improvement_eqns
+                        , text "Candidates:" <+> ppr funeqs_for_tc
+                        , text "Inert eqs:" <+> ppr (inert_eqs inerts) ]
+       ; emitFunDepWanteds (ctEvRewriters work_ev) improvement_eqns }
+  where
+    funeqs        = inert_funeqs inerts
+    funeqs_for_tc :: [EqCt]
+    funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc
+                               , funeq_ct <- equal_ct_list
+                               , NomEq == eq_eq_rel funeq_ct ]
+                                  -- representational equalities don't interact
+                                  -- with type family dependencies
+    work_loc      = ctEvLoc work_ev
+    work_pred     = ctEvPred work_ev
+    fam_inj_info  = tyConInjectivityInfo fam_tc
+
+    --------------------
+    improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)]
+    improvement_eqns
+      | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+      =    -- Try built-in families, notably for arithmethic
+        concatMap (do_one_built_in ops rhs) funeqs_for_tc
+
+      | Injective injective_args <- fam_inj_info
+      =    -- Try improvement from type families with injectivity annotations
+        concatMap (do_one_injective injective_args rhs) funeqs_for_tc
+
+      | otherwise
+      = []
+
+    --------------------
+    do_one_built_in ops rhs (EqCt { eq_lhs = TyFamLHS _ iargs, eq_rhs = irhs, eq_ev = inert_ev })
+      | not (isGiven inert_ev && isGiven work_ev)  -- See Note [No Given/Given fundeps]
+      = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs)
+
+      | otherwise
+      = []
+
+    do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc) -- TyVarLHS
+
+    --------------------
+    -- See Note [Type inference for type families with injectivity]
+    do_one_injective inj_args rhs (EqCt { eq_lhs = TyFamLHS _ inert_args
+                                        , eq_rhs = irhs, eq_ev = inert_ev })
+      | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps]
+      , rhs `tcEqType` irhs
+      = mk_fd_eqns inert_ev $ [ Pair arg iarg
+                              | (arg, iarg, True) <- zip3 args inert_args inj_args ]
+      | otherwise
+      = []
+
+    do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)  -- TyVarLHS
+
+    --------------------
+    mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)]
+    mk_fd_eqns inert_ev eqns
+      | null eqns  = []
+      | otherwise  = [ FDEqn { fd_qtvs = [], fd_eqs = eqns
+                             , fd_pred1 = work_pred
+                             , fd_pred2 = inert_pred
+                             , fd_loc   = (loc, inert_rewriters) } ]
+      where
+        initial_loc  -- start with the location of the Wanted involved
+          | isGiven work_ev = inert_loc
+          | otherwise       = work_loc
+        eqn_orig        = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc)
+                                       inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc)
+        eqn_loc         = setCtLocOrigin initial_loc eqn_orig
+        inert_pred      = ctEvPred inert_ev
+        inert_loc       = ctEvLoc inert_ev
+        inert_rewriters = ctEvRewriters inert_ev
+        loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`
+                                    ctl_depth work_loc }
+
+{- Note [Type inference for type families with injectivity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have a type family with an injectivity annotation:
+    type family F a b = r | r -> b
+
+Then if we have an equality like F s1 t1 ~ F s2 t2,
+we can use the injectivity to get a new Wanted constraint on
+the injective argument
+  [W] t1 ~ t2
+
+That in turn can help GHC solve constraints that would otherwise require
+guessing.  For example, consider the ambiguity check for
+   f :: F Int b -> Int
+We get the constraint
+   [W] F Int b ~ F Int beta
+where beta is a unification variable.  Injectivity lets us pick beta ~ b.
+
+Injectivity information is also used at the call sites. For example:
+   g = f True
+gives rise to
+   [W] F Int b ~ Bool
+from which we can derive b.  This requires looking at the defining equations of
+a type family, ie. finding equation with a matching RHS (Bool in this example)
+and inferring values of type variables (b in this example) from the LHS patterns
+of the matching equation.  For closed type families we have to perform
+additional apartness check for the selected equation to check that the selected
+is guaranteed to fire for given LHS arguments.
+
+These new constraints are Wanted constraints, but we will not use the evidence.
+We could go further and offer evidence from decomposing injective type-function
+applications, but that would require new evidence forms, and an extension to
+FC, so we don't do that right now (Dec 14).
+
+We generate these Wanteds in three places, depending on how we notice the
+injectivity.
+
+1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and
+described in Note [Decomposing type family applications] in GHC.Tc.Solver.Canonical.
+
+2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these
+constraints rewrites the other, as they have different LHSs. This is done
+in improveLocalFunEqs, called during the interactWithInertsStage.
+
+3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T.
+This is done in improve_top_fun_eqs, called from the top-level reactions stage.
+
+See also Note [Injective type families] in GHC.Core.TyCon
+
+Note [Cache-caused loops]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
+solved cache (which is the default behaviour or xCtEvidence), because the interaction
+may not be contributing towards a solution. Here is an example:
+
+Initial inert set:
+  [W] g1 : F a ~ beta1
+Work item:
+  [W] g2 : F a ~ beta2
+The work item will react with the inert yielding the _same_ inert set plus:
+    (i)   Will set g2 := g1 `cast` g3
+    (ii)  Will add to our solved cache that [S] g2 : F a ~ beta2
+    (iii) Will emit [W] g3 : beta1 ~ beta2
+Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2
+and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it
+will set
+      g1 := g ; sym g3
+and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but
+remember that we have this in our solved cache, and it is ... g2! In short we
+created the evidence loop:
+
+        g2 := g1 ; g3
+        g3 := refl
+        g1 := g2 ; sym g3
+
+To avoid this situation we do not cache as solved any workitems (or inert)
+which did not really made a 'step' towards proving some goal. Solved's are
+just an optimization so we don't lose anything in terms of completeness of
+solving.
+-}
\ No newline at end of file
diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs
index 3b565f378c..ed1386380a 100644
--- a/compiler/GHC/Tc/Solver/InertSet.hs
+++ b/compiler/GHC/Tc/Solver/InertSet.hs
@@ -28,6 +28,7 @@ module GHC.Tc.Solver.InertSet (
     -- * Inert equalities
     foldTyEqs, delEq, findEq,
     partitionInertEqs, partitionFunEqs,
+    foldFunEqs,
 
     -- * Kick-out
     kickOutRewritableLHS,
@@ -63,7 +64,6 @@ import GHC.Utils.Misc       ( partitionWith )
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 
-import Data.List          ( partition )
 import Data.List.NonEmpty ( NonEmpty(..), (<|) )
 import qualified Data.List.NonEmpty as NE
 import GHC.Utils.Panic.Plain
@@ -279,12 +279,12 @@ instance Outputable InertSet where
 
 emptyInertCans :: InertCans
 emptyInertCans
-  = IC { inert_eqs          = emptyDVarEnv
+  = IC { inert_eqs          = emptyTyEqs
+       , inert_funeqs       = emptyFunEqs
        , inert_given_eq_lvl = topTcLevel
        , inert_given_eqs    = False
        , inert_dicts        = emptyDictMap
        , inert_safehask     = emptyDictMap
-       , inert_funeqs       = emptyFunEqs
        , inert_insts        = []
        , inert_irreds       = emptyCts }
 
@@ -1073,11 +1073,11 @@ need to be revisited, but we don't think that the end conclusion is wrong.
 data InertCans   -- See Note [Detailed InertCans Invariants] for more
   = IC { inert_eqs :: InertEqs
               -- See Note [inert_eqs: the inert equalities]
-              -- All CEqCans with a TyVarLHS; index is the LHS tyvar
+              -- All EqCt with a TyVarLHS; index is the LHS tyvar
               -- Domain = skolems and untouchables; a touchable would be unified
 
-       , inert_funeqs :: FunEqMap EqualCtList
-              -- All CEqCans with a TyFamLHS; index is the whole family head type.
+       , inert_funeqs :: InertFunEqs
+              -- All EqCt with a TyFamLHS; index is the whole family head type.
               -- LHS is fully rewritten (modulo eqCanRewrite constraints)
               --     wrt inert_eqs
               -- Can include both [G] and [W]
@@ -1118,6 +1118,7 @@ data InertCans   -- See Note [Detailed InertCans Invariants] for more
        }
 
 type InertEqs    = DTyVarEnv EqualCtList
+type InertFunEqs = FunEqMap  EqualCtList
 
 instance Outputable InertCans where
   ppr (IC { inert_eqs = eqs
@@ -1131,23 +1132,23 @@ instance Outputable InertCans where
 
     = braces $ vcat
       [ ppUnless (isEmptyDVarEnv eqs) $
-        text "Equalities:"
-          <+> pprCts (foldDVarEnv folder emptyCts eqs)
+        text "Equalities ="
+          <+> pprBag (foldTyEqs consBag eqs emptyBag)
       , ppUnless (isEmptyTcAppMap funeqs) $
-        text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts)
+        text "Type-function equalities ="
+          <+> pprBag (foldFunEqs consBag funeqs emptyBag)
       , ppUnless (isEmptyTcAppMap dicts) $
-        text "Dictionaries =" <+> pprCts (dictsToBag dicts)
+        text "Dictionaries =" <+> pprBag (dictsToBag dicts)
       , ppUnless (isEmptyTcAppMap safehask) $
-        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)
+        text "Safe Haskell unsafe overlap =" <+> pprBag (dictsToBag safehask)
       , ppUnless (isEmptyCts irreds) $
-        text "Irreds =" <+> pprCts irreds
+        text "Irreds =" <+> pprBag irreds
       , ppUnless (null insts) $
         text "Given instances =" <+> vcat (map ppr insts)
       , text "Innermost given equalities =" <+> ppr ge_lvl
       , text "Given eqs at this level =" <+> ppr given_eqs
       ]
-    where
-      folder eqs rest = listToBag eqs `andCts` rest
+
 
 {- *********************************************************************
 *                                                                      *
@@ -1155,43 +1156,37 @@ instance Outputable InertCans where
 *                                                                      *
 ********************************************************************* -}
 
-addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs
+emptyTyEqs :: InertEqs
+emptyTyEqs = emptyDVarEnv
+
+addTyEq :: InertEqs -> TcTyVar -> EqCt -> InertEqs
 addTyEq old_eqs tv ct
   = extendDVarEnv_C add_eq old_eqs tv [ct]
   where
     add_eq old_eqs _ = addToEqualCtList ct old_eqs
 
-addCanFunEq :: FunEqMap EqualCtList -> TyCon -> [TcType] -> Ct
-            -> FunEqMap EqualCtList
-addCanFunEq old_eqs fun_tc fun_args ct
-  = alterTcApp old_eqs fun_tc fun_args upd
-  where
-    upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list
-    upd Nothing                  = Just [ct]
-
-foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b
+foldTyEqs :: (EqCt -> b -> b) -> InertEqs -> b -> b
 foldTyEqs k eqs z
   = foldDVarEnv (\cts z -> foldr k z cts) z eqs
 
-findTyEqs :: InertCans -> TyVar -> [Ct]
+findTyEqs :: InertCans -> TyVar -> [EqCt]
 findTyEqs icans tv = concat @Maybe (lookupDVarEnv (inert_eqs icans) tv)
 
-delEq :: InertCans -> CanEqLHS -> TcType -> InertCans
-delEq ic lhs rhs = case lhs of
+delEq :: InertCans -> EqCt -> InertCans
+delEq ic (EqCt { eq_lhs = lhs, eq_rhs = rhs }) = case lhs of
     TyVarLHS tv
       -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv }
     TyFamLHS tf args
       -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd }
   where
-    isThisOne :: Ct -> Bool
-    isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1
-    isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other)
+    isThisOne :: EqCt -> Bool
+    isThisOne (EqCt { eq_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1
 
     upd :: Maybe EqualCtList -> Maybe EqualCtList
     upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list
     upd Nothing           = Nothing
 
-findEq :: InertCans -> CanEqLHS -> [Ct]
+findEq :: InertCans -> CanEqLHS -> [EqCt]
 findEq icans (TyVarLHS tv) = findTyEqs icans tv
 findEq icans (TyFamLHS fun_tc fun_args)
   = concat @Maybe (findFunEq (inert_funeqs icans) fun_tc fun_args)
@@ -1200,46 +1195,51 @@ findEq icans (TyFamLHS fun_tc fun_args)
 partition_eqs_container
   :: forall container
    . container    -- empty container
-  -> (forall b. (EqualCtList -> b -> b) -> b -> container -> b) -- folder
-  -> (container -> CanEqLHS -> EqualCtList -> container)  -- extender
-  -> (Ct -> Bool)
+  -> (forall b. (EqCt -> b -> b) ->  container -> b -> b) -- folder
+  -> (container -> EqCt -> container)  -- extender
+  -> (EqCt -> Bool)
   -> container
-  -> ([Ct], container)
+  -> ([EqCt], container)
 partition_eqs_container empty_container fold_container extend_container pred orig_inerts
-  = fold_container folder ([], empty_container) orig_inerts
+  = fold_container folder orig_inerts ([], empty_container)
   where
-    folder :: EqualCtList -> ([Ct], container) -> ([Ct], container)
-    folder eqs (acc_true, acc_false)
-      = (eqs_true ++ acc_true, acc_false')
-      where
-        (eqs_true, eqs_false) = partition pred eqs
-
-        acc_false'
-          | CEqCan { cc_lhs = lhs } : _ <- eqs_false
-          = extend_container acc_false lhs eqs_false
-          | otherwise
-          = acc_false
+    folder :: EqCt -> ([EqCt], container) -> ([EqCt], container)
+    folder eq_ct (acc_true, acc_false)
+      | pred eq_ct = (eq_ct : acc_true, acc_false)
+      | otherwise  = (acc_true,         extend_container acc_false eq_ct)
 
-partitionInertEqs :: (Ct -> Bool)   -- Ct will always be a CEqCan with a TyVarLHS
+partitionInertEqs :: (EqCt -> Bool)   -- EqCt will always have a TyVarLHS
                   -> InertEqs
-                  -> ([Ct], InertEqs)
-partitionInertEqs = partition_eqs_container emptyDVarEnv foldDVarEnv extendInertEqs
+                  -> ([EqCt], InertEqs)
+partitionInertEqs = partition_eqs_container emptyTyEqs foldTyEqs extendInertEqs
+
+extendInertEqs :: InertEqs -> EqCt -> InertEqs
+-- Precondition: CanEqLHS is a TyVarLHS
+extendInertEqs eqs eq_ct@(EqCt { eq_lhs = TyVarLHS tv }) = addTyEq eqs tv eq_ct
+extendInertEqs _ other = pprPanic "extendInertEqs" (ppr other)
+
+------------------------
+
+addCanFunEq :: InertFunEqs -> TyCon -> [TcType] -> EqCt -> InertFunEqs
+addCanFunEq old_eqs fun_tc fun_args ct
+  = alterTcApp old_eqs fun_tc fun_args upd
+  where
+    upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list
+    upd Nothing                  = Just [ct]
 
--- precondition: CanEqLHS is a TyVarLHS
-extendInertEqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs
-extendInertEqs eqs (TyVarLHS tv) new_eqs = extendDVarEnv eqs tv new_eqs
-extendInertEqs _ other _ = pprPanic "extendInertEqs" (ppr other)
+foldFunEqs :: (EqCt -> b -> b) -> FunEqMap EqualCtList -> b -> b
+foldFunEqs k fun_eqs z = foldTcAppMap (\eqs z -> foldr k z eqs) fun_eqs z
 
-partitionFunEqs :: (Ct -> Bool)    -- Ct will always be a CEqCan with a TyFamLHS
-                -> FunEqMap EqualCtList
-                -> ([Ct], FunEqMap EqualCtList)
-partitionFunEqs
-  = partition_eqs_container emptyFunEqs (\ f z eqs -> foldFunEqs f eqs z) extendFunEqs
+partitionFunEqs :: (EqCt -> Bool)    -- EqCt will have a TyFamLHS
+                -> InertFunEqs
+                -> ([EqCt], InertFunEqs)
+partitionFunEqs = partition_eqs_container emptyFunEqs foldFunEqs extendFunEqs
 
--- precondition: CanEqLHS is a TyFamLHS
-extendFunEqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList -> FunEqMap EqualCtList
-extendFunEqs eqs (TyFamLHS tf args) new_eqs = insertTcApp eqs tf args new_eqs
-extendFunEqs _ other _ = pprPanic "extendFunEqs" (ppr other)
+extendFunEqs :: InertFunEqs -> EqCt -> InertFunEqs
+-- Precondition: EqCt is a TyFamLHS
+extendFunEqs fun_eqs eq_ct@(EqCt { eq_lhs = TyFamLHS tc args })
+  = addCanFunEq fun_eqs tc args eq_ct
+extendFunEqs _       other = pprPanic "extendFunEqs" (ppr other)
 
 {- *********************************************************************
 *                                                                      *
@@ -1251,15 +1251,15 @@ extendFunEqs _ other _ = pprPanic "extendFunEqs" (ppr other)
 addInertItem :: TcLevel -> InertCans -> Ct -> InertCans
 addInertItem tc_lvl
              ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs })
-             item@(CEqCan { cc_lhs = lhs })
+             item@(CEqCan eq_ct)
   = updateGivenEqs tc_lvl item $
-    case lhs of
-       TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys item }
-       TyVarLHS tv     -> ics { inert_eqs    = addTyEq eqs tv item }
+    case eq_lhs eq_ct of
+       TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys eq_ct }
+       TyVarLHS tv     -> ics { inert_eqs    = addTyEq eqs tv eq_ct }
 
 addInertItem tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {})
   = updateGivenEqs tc_lvl item $   -- An Irred might turn out to be an
-                                 -- equality, so we play safe
+                                   -- equality, so we play safe
     ics { inert_irreds = irreds `snocBag` item }
 
 addInertItem _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })
@@ -1292,9 +1292,9 @@ updateGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl })
     --          See Note [Let-bound skolems]
     -- NB: no need to spot the boxed CDictCan (a ~ b) because its
     --     superclass (a ~# b) will be a CEqCan
-    not_equality (CEqCan { cc_lhs = TyVarLHS tv }) = not (isOuterTyVar tclvl tv)
-    not_equality (CDictCan {})                     = True
-    not_equality _                                 = False
+    not_equality (CEqCan (EqCt { eq_lhs = TyVarLHS tv })) = not (isOuterTyVar tclvl tv)
+    not_equality (CDictCan {})                            = True
+    not_equality _                                        = False
 
 kickOutRewritableLHS :: CtFlavourRole  -- Flavour/role of the equality that
                                        -- is being added to the inert set
@@ -1325,7 +1325,8 @@ kickOutRewritableLHS new_fr new_lhs
     -- is substituted; ditto the dictionaries, which may include (a~b)
     -- or (a~~b) constraints.
     kicked_out = foldr extendWorkListCt
-                          (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out })
+                          (emptyWorkList { wl_eqs = map CEqCan tv_eqs_out ++
+                                                    map CEqCan feqs_out })
                           ((dicts_out `andCts` irs_out)
                             `extendCtsList` insts_out)
 
@@ -1397,9 +1398,9 @@ kickOutRewritableLHS new_fr new_lhs
                && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct)
 
     -- Implements criteria K1-K3 in Note [Extending the inert equalities]
-    kick_out_eq :: Ct -> Bool
-    kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty
-                        , cc_ev = ev, cc_eq_rel = eq_rel })
+    kick_out_eq :: EqCt -> Bool
+    kick_out_eq (EqCt { eq_lhs = lhs, eq_rhs = rhs_ty
+                      , eq_ev = ev, eq_eq_rel = eq_rel })
       | not (fr_may_rewrite fs)
       = False  -- (K0) Keep it in the inert set if the new thing can't rewrite it
 
@@ -1430,7 +1431,6 @@ kickOutRewritableLHS new_fr new_lhs
               NomEq  -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a)
               ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty    -- (K3b)
 
-    kick_out_eq ct = pprPanic "kick_out_eq" (ppr ct)
 
     is_can_eq_lhs_head (TyVarLHS tv) = go
       where
diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs
index 703efdf786..a46bccac79 100644
--- a/compiler/GHC/Tc/Solver/Interact.hs
+++ b/compiler/GHC/Tc/Solver/Interact.hs
@@ -6,50 +6,36 @@ module GHC.Tc.Solver.Interact (
   ) where
 
 import GHC.Prelude
-import GHC.Types.Basic ( SwapFlag(..), IntWithInf, intGtLimit )
-import GHC.Tc.Solver.Canonical
-import GHC.Types.Var.Set
 
-import GHC.Types.Var
+import GHC.Tc.Solver.Canonical
+import GHC.Tc.Solver.Dict
 import GHC.Tc.Errors.Types
 import GHC.Tc.Utils.TcType
-import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey )
 import GHC.Tc.Instance.FunDeps
-import GHC.Tc.Instance.Family
 import GHC.Tc.Instance.Class ( safeOverlap )
-
 import GHC.Tc.Types.Evidence
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
 import GHC.Tc.Types
 import GHC.Tc.Types.Constraint
 import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcMType( promoteMetaTyVarTo )
 import GHC.Tc.Solver.Types
 import GHC.Tc.Solver.InertSet
 import GHC.Tc.Solver.Monad
 
-import GHC.Core
-import GHC.Core.Type as Type
-import GHC.Core.InstEnv     ( DFunInstType, Coherence(..) )
+import GHC.Core.InstEnv     ( Coherence(..) )
 import GHC.Core.Class
-import GHC.Core.TyCon
 import GHC.Core.Predicate
 import GHC.Core.Coercion
-import GHC.Core.FamInstEnv
-import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX )
-import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches
-                               , sfInteractInert, sfInteractTop )
 
-import GHC.Types.SrcLoc
-import GHC.Types.Var.Env
+import GHC.Builtin.Names ( ipClassKey )
+
 import GHC.Types.Unique( hasKey )
+import GHC.Types.Basic ( SwapFlag(..), IntWithInf, intGtLimit )
 
 import GHC.Data.Bag
-import GHC.Data.Pair (Pair(..))
 
-import GHC.Utils.Monad ( concatMapM, foldlM )
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Monad ( foldlM )
 import GHC.Utils.Misc
 
 import GHC.Driver.Session
@@ -57,9 +43,7 @@ import GHC.Driver.Session
 import qualified GHC.LanguageExtensions as LangExt
 
 import Data.List( deleteFirstsBy )
-import Data.Maybe ( listToMaybe, mapMaybe )
 import Data.Function ( on )
-import qualified Data.Semigroup as S
 
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
@@ -432,9 +416,10 @@ interactWithInertsStage wi
   = do { inerts <- getTcSInerts
        ; let ics = inert_cans inerts
        ; case wi of
-             CEqCan       {} -> interactEq      ics wi
              CIrredCan    {} -> interactIrred   ics wi
              CDictCan     {} -> interactDict    ics wi
+             CEqCan       {} -> continueWith wi  -- "Canonicalisation" stage is
+                                                 -- full solver for equalities
              _ -> pprPanic "interactWithInerts" (ppr wi) }
                 -- CNonCanonical have been canonicalised
 
@@ -1278,696 +1263,6 @@ I can think of two ways to fix this:
 
 **********************************************************************
 *                                                                    *
-                   interactFunEq
-*                                                                    *
-**********************************************************************
--}
-
-improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType
-                   -> TcS ()
--- Generate improvement equalities, by comparing
--- the current work item with inert CFunEqs
--- E.g.   x + y ~ z,   x + y' ~ z   =>   [W] y ~ y'
---
--- See Note [FunDep and implicit parameter reactions]
-improveLocalFunEqs work_ev inerts fam_tc args rhs
-  = unless (null improvement_eqns) $
-    do { traceTcS "interactFunEq improvements: " $
-                   vcat [ text "Eqns:" <+> ppr improvement_eqns
-                        , text "Candidates:" <+> ppr funeqs_for_tc
-                        , text "Inert eqs:" <+> ppr (inert_eqs inerts) ]
-       ; emitFunDepWanteds (ctEvRewriters work_ev) improvement_eqns }
-  where
-    funeqs        = inert_funeqs inerts
-    funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc
-                               , funeq_ct <- equal_ct_list
-                               , NomEq == ctEqRel funeq_ct ]
-                                  -- representational equalities don't interact
-                                  -- with type family dependencies
-    work_loc      = ctEvLoc work_ev
-    work_pred     = ctEvPred work_ev
-    fam_inj_info  = tyConInjectivityInfo fam_tc
-
-    --------------------
-    improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)]
-    improvement_eqns
-      | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
-      =    -- Try built-in families, notably for arithmethic
-        concatMap (do_one_built_in ops rhs) funeqs_for_tc
-
-      | Injective injective_args <- fam_inj_info
-      =    -- Try improvement from type families with injectivity annotations
-        concatMap (do_one_injective injective_args rhs) funeqs_for_tc
-
-      | otherwise
-      = []
-
-    --------------------
-    do_one_built_in ops rhs (CEqCan { cc_lhs = TyFamLHS _ iargs, cc_rhs = irhs, cc_ev = inert_ev })
-      | not (isGiven inert_ev && isGiven work_ev)  -- See Note [No Given/Given fundeps]
-      = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs)
-
-      | otherwise
-      = []
-
-    do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)
-
-    --------------------
-    -- See Note [Type inference for type families with injectivity]
-    do_one_injective inj_args rhs (CEqCan { cc_lhs = TyFamLHS _ inert_args
-                                          , cc_rhs = irhs, cc_ev = inert_ev })
-      | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps]
-      , rhs `tcEqType` irhs
-      = mk_fd_eqns inert_ev $ [ Pair arg iarg
-                              | (arg, iarg, True) <- zip3 args inert_args inj_args ]
-      | otherwise
-      = []
-
-    do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)
-
-    --------------------
-    mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)]
-    mk_fd_eqns inert_ev eqns
-      | null eqns  = []
-      | otherwise  = [ FDEqn { fd_qtvs = [], fd_eqs = eqns
-                             , fd_pred1 = work_pred
-                             , fd_pred2 = inert_pred
-                             , fd_loc   = (loc, inert_rewriters) } ]
-      where
-        initial_loc  -- start with the location of the Wanted involved
-          | isGiven work_ev = inert_loc
-          | otherwise       = work_loc
-        eqn_orig        = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc)
-                                       inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc)
-        eqn_loc         = setCtLocOrigin initial_loc eqn_orig
-        inert_pred      = ctEvPred inert_ev
-        inert_loc       = ctEvLoc inert_ev
-        inert_rewriters = ctEvRewriters inert_ev
-        loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`
-                                    ctl_depth work_loc }
-
-{- Note [Type inference for type families with injectivity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have a type family with an injectivity annotation:
-    type family F a b = r | r -> b
-
-Then if we have an equality like F s1 t1 ~ F s2 t2,
-we can use the injectivity to get a new Wanted constraint on
-the injective argument
-  [W] t1 ~ t2
-
-That in turn can help GHC solve constraints that would otherwise require
-guessing.  For example, consider the ambiguity check for
-   f :: F Int b -> Int
-We get the constraint
-   [W] F Int b ~ F Int beta
-where beta is a unification variable.  Injectivity lets us pick beta ~ b.
-
-Injectivity information is also used at the call sites. For example:
-   g = f True
-gives rise to
-   [W] F Int b ~ Bool
-from which we can derive b.  This requires looking at the defining equations of
-a type family, ie. finding equation with a matching RHS (Bool in this example)
-and inferring values of type variables (b in this example) from the LHS patterns
-of the matching equation.  For closed type families we have to perform
-additional apartness check for the selected equation to check that the selected
-is guaranteed to fire for given LHS arguments.
-
-These new constraints are Wanted constraints, but we will not use the evidence.
-We could go further and offer evidence from decomposing injective type-function
-applications, but that would require new evidence forms, and an extension to
-FC, so we don't do that right now (Dec 14).
-
-We generate these Wanteds in three places, depending on how we notice the
-injectivity.
-
-1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and
-described in Note [Decomposing type family applications] in GHC.Tc.Solver.Canonical.
-
-2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these
-constraints rewrites the other, as they have different LHSs. This is done
-in improveLocalFunEqs, called during the interactWithInertsStage.
-
-3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T.
-This is done in improve_top_fun_eqs, called from the top-level reactions stage.
-
-See also Note [Injective type families] in GHC.Core.TyCon
-
-Note [Cache-caused loops]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
-solved cache (which is the default behaviour or xCtEvidence), because the interaction
-may not be contributing towards a solution. Here is an example:
-
-Initial inert set:
-  [W] g1 : F a ~ beta1
-Work item:
-  [W] g2 : F a ~ beta2
-The work item will react with the inert yielding the _same_ inert set plus:
-    (i)   Will set g2 := g1 `cast` g3
-    (ii)  Will add to our solved cache that [S] g2 : F a ~ beta2
-    (iii) Will emit [W] g3 : beta1 ~ beta2
-Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2
-and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it
-will set
-      g1 := g ; sym g3
-and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but
-remember that we have this in our solved cache, and it is ... g2! In short we
-created the evidence loop:
-
-        g2 := g1 ; g3
-        g3 := refl
-        g1 := g2 ; sym g3
-
-To avoid this situation we do not cache as solved any workitems (or inert)
-which did not really made a 'step' towards proving some goal. Solved's are
-just an optimization so we don't lose anything in terms of completeness of
-solving.
-
-**********************************************************************
-*                                                                    *
-                   interactEq
-*                                                                    *
-**********************************************************************
--}
-
-{- Note [Combining equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-   Inert:     g1 :: a ~ t
-   Work item: g2 :: a ~ t
-
-Then we can simply solve g2 from g1, thus g2 := g1.  Easy!
-But it's not so simple:
-
-* If t is a type variable, the equalties might be oriented differently:
-      e.g. (g1 :: a~b) and (g2 :: b~a)
-  So we look both ways round.  Hence the SwapFlag result to
-  inertsCanDischarge.
-
-* We can only do g2 := g1 if g1 can discharge g2; that depends on
-  (a) the role and (b) the flavour.  E.g. a representational equality
-  cannot discharge a nominal one; a Wanted cannot discharge a Given.
-  The predicate is eqCanRewriteFR.
-
-* Visibility. Suppose  S :: forall k. k -> Type, and consider unifying
-      S @Type (a::Type)  ~   S @(Type->Type) (b::Type->Type)
-  From the first argument we get (Type ~ Type->Type); from the second
-  argument we get (a ~ b) which in turn gives (Type ~ Type->Type).
-  See typecheck/should_fail/T16204c.
-
-  That first argument is invisible in the source program (aside from
-  visible type application), so we'd much prefer to get the error from
-  the second. We track visibility in the uo_visible field of a TypeEqOrigin.
-  We use this to prioritise visible errors (see GHC.Tc.Errors.tryReporters,
-  the partition on isVisibleOrigin).
-
-  So when combining two otherwise-identical equalites, we want to
-  keep the visible one, and discharge the invisible one.  Hence the
-  call to strictly_more_visible.
--}
-
-inertsCanDischarge :: InertCans -> Ct
-                   -> Maybe ( CtEvidence  -- The evidence for the inert
-                            , SwapFlag )  -- Whether we need mkSymCo
-inertsCanDischarge inerts (CEqCan { cc_lhs = lhs_w, cc_rhs = rhs_w
-                                  , cc_ev = ev_w, cc_eq_rel = eq_rel })
-  | (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i
-                                  , cc_eq_rel = eq_rel }
-                             <- findEq inerts lhs_w
-                         , rhs_i `tcEqType` rhs_w
-                         , inert_beats_wanted ev_i eq_rel ]
-  =  -- Inert:     a ~ ty
-     -- Work item: a ~ ty
-    Just (ev_i, NotSwapped)
-
-  | Just rhs_lhs <- canEqLHS_maybe rhs_w
-  , (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i
-                                  , cc_eq_rel = eq_rel }
-                             <- findEq inerts rhs_lhs
-                         , rhs_i `tcEqType` canEqLHSType lhs_w
-                         , inert_beats_wanted ev_i eq_rel ]
-  =  -- Inert:     a ~ b
-     -- Work item: b ~ a
-     Just (ev_i, IsSwapped)
-
-  where
-    loc_w  = ctEvLoc ev_w
-    flav_w = ctEvFlavour ev_w
-    fr_w   = (flav_w, eq_rel)
-
-    inert_beats_wanted ev_i eq_rel
-      = -- eqCanRewriteFR:        see second bullet of Note [Combining equalities]
-        -- strictly_more_visible: see last bullet of Note [Combining equalities]
-        fr_i `eqCanRewriteFR` fr_w
-        && not ((loc_w `strictly_more_visible` ctEvLoc ev_i)
-                 && (fr_w `eqCanRewriteFR` fr_i))
-      where
-        fr_i = (ctEvFlavour ev_i, eq_rel)
-
-    -- See Note [Combining equalities], final bullet
-    strictly_more_visible loc1 loc2
-       = not (isVisibleOrigin (ctLocOrigin loc2)) &&
-         isVisibleOrigin (ctLocOrigin loc1)
-
-inertsCanDischarge _ _ = Nothing
-
-
-interactEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
-interactEq inerts workItem@(CEqCan { cc_lhs = lhs
-                                   , cc_rhs = rhs
-                                   , cc_ev = ev
-                                   , cc_eq_rel = eq_rel })
-  | Just (ev_i, swapped) <- inertsCanDischarge inerts workItem
-  = do { setEvBindIfWanted ev IsCoherent $
-         evCoercion (maybeSymCo swapped $
-                     downgradeRole (eqRelRole eq_rel)
-                                   (ctEvRole ev_i)
-                                   (ctEvCoercion ev_i))
-
-       ; stopWith ev "Solved from inert" }
-
-  | ReprEq <- eq_rel   -- See Note [Do not unify representational equalities]
-  = do { traceTcS "Not unifying representational equality" (ppr workItem)
-       ; continueWith workItem }
-
-  | otherwise
-  = case lhs of
-       TyVarLHS tv -> tryToSolveByUnification workItem ev tv rhs
-
-       TyFamLHS tc args -> do { improveLocalFunEqs ev inerts tc args rhs
-                              ; continueWith workItem }
-
-interactEq _ wi = pprPanic "interactEq" (ppr wi)
-
-----------------------
--- We have a meta-tyvar on the left, and metaTyVarUpdateOK has said "yes"
--- So try to solve by unifying.
--- Three reasons why not:
---    Skolem escape
---    Given equalities (GADTs)
---    Unifying a TyVarTv with a non-tyvar type
-tryToSolveByUnification :: Ct -> CtEvidence
-                        -> TcTyVar   -- LHS tyvar
-                        -> TcType    -- RHS
-                        -> TcS (StopOrContinue Ct)
-tryToSolveByUnification work_item ev tv rhs
-  = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv rhs
-       ; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs
-                                                  , ppr is_touchable ])
-
-       ; case is_touchable of
-           Untouchable -> continueWith work_item
-           -- For the latter two cases see Note [Solve by unification]
-           TouchableSameLevel -> solveByUnification ev tv rhs
-           TouchableOuterLevel free_metas tv_lvl
-             -> do { wrapTcS $ mapM_ (promoteMetaTyVarTo tv_lvl) free_metas
-                   ; setUnificationFlag tv_lvl
-                   ; solveByUnification ev tv rhs } }
-
-solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS (StopOrContinue Ct)
--- Solve with the identity coercion
--- Precondition: kind(xi) equals kind(tv)
--- Precondition: CtEvidence is Wanted
--- Precondition: CtEvidence is nominal
--- Returns: workItem where
---        workItem = the new Given constraint
---
--- NB: No need for an occurs check here, because solveByUnification always
---     arises from a CEqCan, a *canonical* constraint.  Its invariant (TyEq:OC)
---     says that in (a ~ xi), the type variable a does not appear in xi.
---     See GHC.Tc.Types.Constraint.Ct invariants.
---
--- Post: tv is unified (by side effect) with xi;
---       we often write tv := xi
-solveByUnification wd tv xi
-  = do { let tv_ty = mkTyVarTy tv
-       ; traceTcS "Sneaky unification:" $
-                       vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi,
-                             text "Coercion:" <+> pprEq tv_ty xi,
-                             text "Left Kind is:" <+> ppr (typeKind tv_ty),
-                             text "Right Kind is:" <+> ppr (typeKind xi) ]
-       ; unifyTyVar tv xi
-       ; setEvBindIfWanted wd IsCoherent (evCoercion (mkNomReflCo xi))
-       ; n_kicked <- kickOutAfterUnification tv
-       ; return (Stop wd (text "Solved by unification" <+> pprKicked n_kicked)) }
-
-{- Note [Avoid double unifications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The spontaneous solver has to return a given which mentions the unified unification
-variable *on the left* of the equality. Here is what happens if not:
-  Original wanted:  (a ~ alpha),  (alpha ~ Int)
-We spontaneously solve the first wanted, without changing the order!
-      given : a ~ alpha      [having unified alpha := a]
-Now the second wanted comes along, but it cannot rewrite the given, so we simply continue.
-At the end we spontaneously solve that guy, *reunifying*  [alpha := Int]
-
-We avoid this problem by orienting the resulting given so that the unification
-variable is on the left (note that alternatively we could attempt to
-enforce this at canonicalization).
-
-See also Note [No touchables as FunEq RHS] in GHC.Tc.Solver.Monad; avoiding
-double unifications is the main reason we disallow touchable
-unification variables as RHS of type family equations: F xis ~ alpha.
-
-Note [Do not unify representational equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider   [W] alpha ~R# b
-where alpha is touchable. Should we unify alpha := b?
-
-Certainly not!  Unifying forces alpha and be to be the same; but they
-only need to be representationally equal types.
-
-For example, we might have another constraint [W] alpha ~# N b
-where
-  newtype N b = MkN b
-and we want to get alpha := N b.
-
-See also #15144, which was caused by unifying a representational
-equality.
-
-Note [Solve by unification]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we solve
-   alpha[n] ~ ty
-by unification, there are two cases to consider
-
-* TouchableSameLevel: if the ambient level is 'n', then
-  we can simply update alpha := ty, and do nothing else
-
-* TouchableOuterLevel free_metas n: if the ambient level is greater than
-  'n' (the level of alpha), in addition to setting alpha := ty we must
-  do two other things:
-
-  1. Promote all the free meta-vars of 'ty' to level n.  After all,
-     alpha[n] is at level n, and so if we set, say,
-          alpha[n] := Maybe beta[m],
-     we must ensure that when unifying beta we do skolem-escape checks
-     etc relevant to level n.  Simple way to do that: promote beta to
-     level n.
-
-  2. Set the Unification Level Flag to record that a level-n unification has
-     taken place. See Note [The Unification Level Flag] in GHC.Tc.Solver.Monad
-
-NB: TouchableSameLevel is just an optimisation for TouchableOuterLevel. Promotion
-would be a no-op, and setting the unification flag unnecessarily would just
-make the solver iterate more often.  (We don't need to iterate when unifying
-at the ambient level because of the kick-out mechanism.)
-
-
-************************************************************************
-*                                                                      *
-*          Functional dependencies, instantiation of equations
-*                                                                      *
-************************************************************************
-
-When we spot an equality arising from a functional dependency,
-we now use that equality (a "wanted") to rewrite the work-item
-constraint right away.  This avoids two dangers
-
- Danger 1: If we send the original constraint on down the pipeline
-           it may react with an instance declaration, and in delicate
-           situations (when a Given overlaps with an instance) that
-           may produce new insoluble goals: see #4952
-
- Danger 2: If we don't rewrite the constraint, it may re-react
-           with the same thing later, and produce the same equality
-           again --> termination worries.
-
-To achieve this required some refactoring of GHC.Tc.Instance.FunDeps (nicer
-now!).
-
-Note [FunDep and implicit parameter reactions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Currently, our story of interacting two dictionaries (or a dictionary
-and top-level instances) for functional dependencies, and implicit
-parameters, is that we simply produce new Wanted equalities.  So for example
-
-        class D a b | a -> b where ...
-    Inert:
-        d1 :g D Int Bool
-    WorkItem:
-        d2 :w D Int alpha
-
-    We generate the extra work item
-        cv :w alpha ~ Bool
-    where 'cv' is currently unused.  However, this new item can perhaps be
-    spontaneously solved to become given and react with d2,
-    discharging it in favour of a new constraint d2' thus:
-        d2' :w D Int Bool
-        d2 := d2' |> D Int cv
-    Now d2' can be discharged from d1
-
-We could be more aggressive and try to *immediately* solve the dictionary
-using those extra equalities.
-
-If that were the case with the same inert set and work item we might discard
-d2 directly:
-
-        cv :w alpha ~ Bool
-        d2 := d1 |> D Int cv
-
-But in general it's a bit painful to figure out the necessary coercion,
-so we just take the first approach. Here is a better example. Consider:
-    class C a b c | a -> b
-And:
-     [Given]  d1 : C T Int Char
-     [Wanted] d2 : C T beta Int
-In this case, it's *not even possible* to solve the wanted immediately.
-So we should simply output the functional dependency and add this guy
-[but NOT its superclasses] back in the worklist. Even worse:
-     [Given] d1 : C T Int beta
-     [Wanted] d2: C T beta Int
-Then it is solvable, but its very hard to detect this on the spot.
-
-It's exactly the same with implicit parameters, except that the
-"aggressive" approach would be much easier to implement.
-
-Note [Fundeps with instances, and equality orientation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This Note describes a delicate interaction that constrains the orientation of
-equalities. This one is about fundeps, but the /exact/ same thing arises for
-type-family injectivity constraints: see Note [Improvement orientation].
-
-doTopFundepImprovement compares the constraint with all the instance
-declarations, to see if we can produce any equalities. E.g
-   class C2 a b | a -> b
-   instance C Int Bool
-Then the constraint (C Int ty) generates the equality [W] ty ~ Bool.
-
-There is a nasty corner in #19415 which led to the typechecker looping:
-   class C s t b | s -> t
-   instance ... => C (T kx x) (T ky y) Int
-   T :: forall k. k -> Type
-
-   work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char
-      where kb0, b0 are unification vars
-
-   ==> {doTopFundepImprovement: compare work_item with instance,
-        generate /fresh/ unification variables kfresh0, yfresh0,
-        emit a new Wanted, and add dwrk to inert set}
-
-   Suppose we emit this new Wanted from the fundep:
-       [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0)
-
-   ==> {solve that equality kb0 := kfresh0, b0 := yfresh0}
-   Now kick out dwrk, since it mentions kb0
-   But now we are back to the start!  Loop!
-
-NB1: This example relies on an instance that does not satisfy the
-     coverage condition (although it may satisfy the weak coverage
-     condition), and hence whose fundeps generate fresh unification
-     variables.  Not satisfying the coverage condition is known to
-     lead to termination trouble, but in this case it's plain silly.
-
-NB2: In this example, the third parameter to C ensures that the
-     instance doesn't actually match the Wanted, so we can't use it to
-     solve the Wanted
-
-We solve the problem by (#21703):
-
-    carefully orienting the new Wanted so that all the
-    freshly-generated unification variables are on the LHS.
-
-    Thus we emit
-       [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0)
-    and /NOT/
-       [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0)
-
-Now we'll unify kfresh0:=kb0, yfresh0:=b0, and all is well.  The general idea
-is that we want to preferentially eliminate those freshly-generated
-unification variables, rather than unifying older variables, which causes
-kick-out etc.
-
-Keeping younger variables on the left also gives very minor improvement in
-the compiler performance by having less kick-outs and allocations (-0.1% on
-average).  Indeed Historical Note [Eliminate younger unification variables]
-in GHC.Tc.Utils.Unify describes an earlier attempt to do so systematically,
-apparently now in abeyance.
-
-But this is is a delicate solution. We must take care to /preserve/
-orientation during solving. Wrinkles:
-
-(W1) We start with
-       [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0)
-     Decompose to
-       [W] kfresh0 ~ kb0
-       [W] (yfresh0::kfresh0) ~ (b0::kb0)
-     Preserve orientiation when decomposing!!
-
-(W2) Suppose we happen to tackle the second Wanted from (W1)
-     first. Then in canEqCanLHSHetero we emit a /kind/ equality, as
-     well as a now-homogeneous type equality
-       [W] kco : kfresh0 ~ kb0
-       [W] (yfresh0::kfresh0) ~ (b0::kb0) |> (sym kco)
-     Preserve orientation in canEqCanLHSHetero!!  (Failing to
-     preserve orientation here was the immediate cause of #21703.)
-
-(W3) There is a potential interaction with the swapping done by
-     GHC.Tc.Utils.Unify.swapOverTyVars.  We think it's fine, but it's
-     a slight worry.  See especially Note [TyVar/TyVar orientation] in
-     that module.
-
-The trouble is that "preserving orientation" is a rather global invariant,
-and sometimes we definitely do want to swap (e.g. Int ~ alpha), so we don't
-even have a precise statement of what the invariant is.  The advantage
-of the preserve-orientation plan is that it is extremely cheap to implement,
-and apparently works beautifully.
-
---- Alternative plan (1) ---
-Rather than have an ill-defined invariant, another possiblity is to
-elminate those fresh unification variables at birth, when generating
-the new fundep-inspired equalities.
-
-The key idea is to call `instFlexiX` in `emitFunDepWanteds` on only those
-type variables that are guaranteed to give us some progress. This means we
-have to locally (without calling emitWanteds) identify the type variables
-that do not give us any progress.  In the above example, we _know_ that
-emitting the two wanteds `kco` and `co` is fruitless.
-
-  Q: How do we identify such no-ops?
-
-  1. Generate a matching substitution from LHS to RHS
-        ɸ = [kb0 :-> k0, b0 :->  y0]
-  2. Call `instFlexiX` on only those type variables that do not appear in the domain of ɸ
-        ɸ' = instFlexiX ɸ (tvs - domain ɸ)
-  3. Apply ɸ' on LHS and then call emitWanteds
-        unifyWanteds ... (subst ɸ' LHS) RHS
-
-Why will this work?  The matching substitution ɸ will be a best effort
-substitution that gives us all the easy solutions. It can be generated with
-modified version of `Core/Unify.unify_tys` where we run it in a matching mode
-and never generate `SurelyApart` and always return a `MaybeApart Subst`
-instead.
-
-The same alternative plan would work for type-family injectivity constraints:
-see Note [Improvement orientation].
---- End of Alternative plan (1) ---
-
---- Alternative plan (2) ---
-We could have a new flavour of TcTyVar (like `TauTv`, `TyVarTv` etc; see GHC.Tc.Utils.TcType.MetaInfo)
-for the fresh unification variables introduced by functional dependencies.  Say `FunDepTv`.  Then in
-GHC.Tc.Utils.Unify.swapOverTyVars we could arrange to keep a `FunDepTv` on the left if possible.
-Looks possible, but it's one more complication.
---- End of Alternative plan (2) ---
-
-
---- Historical note: Failed Alternative Plan (3) ---
-Previously we used a flag `cc_fundeps` in `CDictCan`. It would flip to False
-once we used a fun dep to hint the solver to break and to stop emitting more
-wanteds.  This solution was not complete, and caused a failures while trying
-to solve for transitive functional dependencies (test case: T21703)
--- End of Historical note: Failed Alternative Plan (3) --
-
-Note [Weird fundeps]
-~~~~~~~~~~~~~~~~~~~~
-Consider   class Het a b | a -> b where
-              het :: m (f c) -> a -> m b
-
-           class GHet (a :: * -> *) (b :: * -> *) | a -> b
-           instance            GHet (K a) (K [a])
-           instance Het a b => GHet (K a) (K b)
-
-The two instances don't actually conflict on their fundeps,
-although it's pretty strange.  So they are both accepted. Now
-try   [W] GHet (K Int) (K Bool)
-This triggers fundeps from both instance decls;
-      [W] K Bool ~ K [a]
-      [W] K Bool ~ K beta
-And there's a risk of complaining about Bool ~ [a].  But in fact
-the Wanted matches the second instance, so we never get as far
-as the fundeps.
-
-#7875 is a case in point.
--}
-
-doTopFundepImprovement :: Ct -> TcS ()
--- Try to functional-dependency improvement between the constraint
--- and the top-level instance declarations
--- See Note [Fundeps with instances, and equality orientation]
--- See also Note [Weird fundeps]
-doTopFundepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls
-                                           , cc_tyargs = xis })
-  = do { traceTcS "try_fundeps" (ppr work_item)
-       ; instEnvs <- getInstEnvs
-       ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis
-       ; emitFunDepWanteds (ctEvRewriters ev) fundep_eqns }
-  where
-     dict_pred   = mkClassPred cls xis
-     dict_loc    = ctEvLoc ev
-     dict_origin = ctLocOrigin dict_loc
-
-     mk_ct_loc :: PredType   -- From instance decl
-               -> SrcSpan    -- also from instance deol
-               -> (CtLoc, RewriterSet)
-     mk_ct_loc inst_pred inst_loc
-       = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin
-                                                 inst_pred inst_loc }
-         , emptyRewriterSet )
-
-doTopFundepImprovement work_item = pprPanic "doTopFundepImprovement" (ppr work_item)
-
-emitFunDepWanteds :: RewriterSet  -- from the work item
-                  -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS ()
-
-emitFunDepWanteds _ [] = return () -- common case noop
--- See Note [FunDep and implicit parameter reactions]
-
-emitFunDepWanteds work_rewriters fd_eqns
-  = mapM_ do_one_FDEqn fd_eqns
-  where
-    do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) })
-     | null tvs  -- Common shortcut
-     = do { traceTcS "emitFunDepWanteds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))
-          ; mapM_ (\(Pair ty1 ty2) -> unifyWanted all_rewriters loc Nominal ty1 ty2)
-                  (reverse eqs) }
-             -- See Note [Reverse order of fundep equations]
-
-     | otherwise
-     = do { traceTcS "emitFunDepWanteds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)
-          ; subst <- instFlexiX emptySubst tvs  -- Takes account of kind substitution
-          ; mapM_ (do_one_eq loc all_rewriters subst) (reverse eqs) }
-               -- See Note [Reverse order of fundep equations]
-     where
-       all_rewriters = work_rewriters S.<> rewriters
-
-    do_one_eq loc rewriters subst (Pair ty1 ty2)
-       = unifyWanted rewriters loc Nominal (substTyUnchecked subst' ty1) ty2
-         -- ty2 does not mention fd_qtvs, so no need to subst it.
-         -- See GHC.Tc.Instance.Fundeps Note [Improving against instances]
-         --     Wrinkle (1)
-      where
-         subst' = extendSubstInScopeSet subst (tyCoVarsOfType ty1)
-         -- The free vars of ty1 aren't just fd_qtvs: ty1 is the result
-         -- of matching with the [W] constraint. So we add its free
-         -- vars to InScopeSet, to satisfy substTy's invariants, even
-         -- though ty1 will never (currently) be a poytype, so this
-         -- InScopeSet will never be looked at.
-
-{-
-**********************************************************************
-*                                                                    *
                        The top-reaction Stage
 *                                                                    *
 **********************************************************************
@@ -1984,8 +1279,8 @@ topReactionsStage work_item
              do { inerts <- getTcSInerts
                 ; doTopReactDict inerts work_item }
 
-           CEqCan {} ->
-             doTopReactEq work_item
+           CEqCan {} -> continueWith work_item  -- "Canonicalisation" stage is
+                                                -- full solver for equalities
 
            CIrredCan {} ->
              doTopReactOther work_item
@@ -2005,9 +1300,6 @@ doTopReactOther work_item
   | isGiven ev
   = continueWith work_item
 
-  | EqPred eq_rel t1 t2 <- classifyPredType pred
-  = doTopReactEqPred work_item eq_rel t1 t2
-
   | otherwise
   = do { res <- matchLocalInst pred loc
        ; case res of
@@ -2019,801 +1311,3 @@ doTopReactOther work_item
     loc  = ctEvLoc ev
     pred = ctEvPred ev
 
-{-********************************************************************
-*                                                                    *
-          Top-level reaction for equality constraints (CEqCan)
-*                                                                    *
-********************************************************************-}
-
-doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct)
-doTopReactEqPred work_item eq_rel t1 t2
-  -- See Note [Looking up primitive equalities in quantified constraints]
-  | Just (cls, tys) <- boxEqPred eq_rel t1 t2
-  = do { res <- matchLocalInst (mkClassPred cls tys) loc
-       ; case res of
-           OneInst { cir_mk_ev = mk_ev }
-             -> chooseInstance work_item
-                    (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })
-           _ -> continueWith work_item }
-
-  | otherwise
-  = continueWith work_item
-  where
-    ev   = ctEvidence work_item
-    loc = ctEvLoc ev
-
-    mk_eq_ev cls tys mk_ev evs
-      = case (mk_ev evs) of
-          EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e)
-          ev       -> pprPanic "mk_eq_ev" (ppr ev)
-      where
-        [sc_id] = classSCSelIds cls
-
-{- Note [Looking up primitive equalities in quantified constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For equalities (a ~# b) look up (a ~ b), and then do a superclass
-selection. This avoids having to support quantified constraints whose
-kind is not Constraint, such as (forall a. F a ~# b)
-
-See
- * Note [Evidence for quantified constraints] in GHC.Core.Predicate
- * Note [Equality superclasses in quantified constraints]
-   in GHC.Tc.Solver.Canonical
-
-Note [Reverse order of fundep equations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this scenario (from dependent/should_fail/T13135_simple):
-
-  type Sig :: Type -> Type
-  data Sig a = SigFun a (Sig a)
-
-  type SmartFun :: forall (t :: Type). Sig t -> Type
-  type family SmartFun sig = r | r -> sig where
-    SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig
-
-  [W] SmartFun @kappa sigma ~ (Int -> Bool)
-
-The injectivity of SmartFun allows us to produce two new equalities:
-
-  [W] w1 :: Type ~ kappa
-  [W] w2 :: SigFun @Type Int beta ~ sigma
-
-for some fresh (beta :: SigType). The second Wanted here is actually
-heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa.
-Of course, if we solve the first wanted first, the second becomes homogeneous.
-
-When looking for injectivity-inspired equalities, we work left-to-right,
-producing the two equalities in the order written above. However, these
-equalities are then passed into unifyWanted, which will fail, adding these
-to the work list. However, crucially, the work list operates like a *stack*.
-So, because we add w1 and then w2, we process w2 first. This is silly: solving
-w1 would unlock w2. So we make sure to add equalities to the work
-list in left-to-right order, which requires a few key calls to 'reverse'.
-
-This treatment is also used for class-based functional dependencies, although
-we do not have a program yet known to exhibit a loop there. It just seems
-like the right thing to do.
-
-When this was originally conceived, it was necessary to avoid a loop in T13135.
-That loop is now avoided by continuing with the kind equality (not the type
-equality) in canEqCanLHSHetero (see Note [Equalities with incompatible kinds]
-in GHC.Tc.Solver.Canonical). However, the idea of working left-to-right still
-seems worthwhile, and so the calls to 'reverse' remain.
-
--}
-
---------------------
-doTopReactEq :: Ct -> TcS (StopOrContinue Ct)
-doTopReactEq work_item@(CEqCan { cc_ev = old_ev, cc_lhs = TyFamLHS fam_tc args
-                               , cc_rhs = rhs })
-  = do { improveTopFunEqs old_ev fam_tc args rhs
-       ; doTopReactOther work_item }
-doTopReactEq work_item = doTopReactOther work_item
-
-improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS ()
--- See Note [FunDep and implicit parameter reactions]
-improveTopFunEqs ev fam_tc args rhs
-  | isGiven ev  -- See Note [No Given/Given fundeps]
-  = return ()
-
-  | otherwise
-  = do { fam_envs <- getFamInstEnvs
-       ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs
-       ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs
-                                          , ppr eqns ])
-       ; mapM_ (\(Pair ty1 ty2) -> unifyWanted rewriters loc Nominal ty1 ty2)
-               (reverse eqns) }
-         -- Missing that `reverse` causes T13135 and T13135_simple to loop.
-         -- See Note [Reverse order of fundep equations]
-  where
-    loc = bumpCtLocDepth (ctEvLoc ev)
-        -- ToDo: this location is wrong; it should be FunDepOrigin2
-        -- See #14778
-    rewriters = ctEvRewriters ev
-
-improve_top_fun_eqs :: FamInstEnvs
-                    -> TyCon -> [TcType] -> TcType
-                    -> TcS [TypeEqn]
-improve_top_fun_eqs fam_envs fam_tc args rhs_ty
-  | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
-  = return (sfInteractTop ops args rhs_ty)
-
-  -- see Note [Type inference for type families with injectivity]
-  | isOpenTypeFamilyTyCon fam_tc
-  , Injective injective_args <- tyConInjectivityInfo fam_tc
-  , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc
-  = -- it is possible to have several compatible equations in an open type
-    -- family but we only want to derive equalities from one such equation.
-    do { let improvs = buildImprovementData fam_insts
-                           fi_tvs fi_tys fi_rhs (const Nothing)
-
-       ; traceTcS "improve_top_fun_eqs2" (ppr improvs)
-       ; concatMapM (injImproveEqns injective_args) $
-         take 1 improvs }
-
-  | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc
-  , Injective injective_args <- tyConInjectivityInfo fam_tc
-  = concatMapM (injImproveEqns injective_args) $
-    buildImprovementData (fromBranches (co_ax_branches ax))
-                         cab_tvs cab_lhs cab_rhs Just
-
-  | otherwise
-  = return []
-
-  where
-      in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty)
-
-      buildImprovementData
-          :: [a]                     -- axioms for a TF (FamInst or CoAxBranch)
-          -> (a -> [TyVar])          -- get bound tyvars of an axiom
-          -> (a -> [Type])           -- get LHS of an axiom
-          -> (a -> Type)             -- get RHS of an axiom
-          -> (a -> Maybe CoAxBranch) -- Just => apartness check required
-          -> [( [Type], Subst, [TyVar], Maybe CoAxBranch )]
-             -- Result:
-             -- ( [arguments of a matching axiom]
-             -- , RHS-unifying substitution
-             -- , axiom variables without substitution
-             -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] )
-      buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap =
-          [ (ax_args, subst, unsubstTvs, wrap axiom)
-          | axiom <- axioms
-          , let ax_args = axiomLHS axiom
-                ax_rhs  = axiomRHS axiom
-                ax_tvs  = axiomTVs axiom
-                in_scope1 = in_scope `extendInScopeSetList` ax_tvs
-          , Just subst <- [tcUnifyTyWithTFs False in_scope1 ax_rhs rhs_ty]
-          , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst)
-                unsubstTvs    = filter (notInSubst <&&> isTyVar) ax_tvs ]
-                   -- The order of unsubstTvs is important; it must be
-                   -- in telescope order e.g. (k:*) (a:k)
-
-      injImproveEqns :: [Bool]
-                     -> ([Type], Subst, [TyCoVar], Maybe CoAxBranch)
-                     -> TcS [TypeEqn]
-      injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr)
-        = do { subst <- instFlexiX subst unsubstTvs
-                  -- If the current substitution bind [k -> *], and
-                  -- one of the un-substituted tyvars is (a::k), we'd better
-                  -- be sure to apply the current substitution to a's kind.
-                  -- Hence instFlexiX.   #13135 was an example.
-
-             ; return [ Pair (substTy subst ax_arg) arg
-                        -- NB: the ax_arg part is on the left
-                        -- see Note [Improvement orientation]
-                      | case cabr of
-                          Just cabr' -> apartnessCheck (substTys subst ax_args) cabr'
-                          _          -> True
-                      , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] }
-
-{-
-Note [MATCHING-SYNONYMS]
-~~~~~~~~~~~~~~~~~~~~~~~~
-When trying to match a dictionary (D tau) to a top-level instance, or a
-type family equation (F taus_1 ~ tau_2) to a top-level family instance,
-we do *not* need to expand type synonyms because the matcher will do that for us.
-
-Note [Improvement orientation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also Note [Fundeps with instances, and equality orientation], which describes
-the Exact Same Prolem, with the same solution, but for functional dependencies.
-
-A very delicate point is the orientation of equalities
-arising from injectivity improvement (#12522).  Suppose we have
-  type family F x = t | t -> x
-  type instance F (a, Int) = (Int, G a)
-where G is injective; and wanted constraints
-
-  [W] TF (alpha, beta) ~ fuv
-  [W] fuv ~ (Int, <some type>)
-
-The injectivity will give rise to constraints
-
-  [W] gamma1 ~ alpha
-  [W] Int ~ beta
-
-The fresh unification variable gamma1 comes from the fact that we
-can only do "partial improvement" here; see Section 5.2 of
-"Injective type families for Haskell" (HS'15).
-
-Now, it's very important to orient the equations this way round,
-so that the fresh unification variable will be eliminated in
-favour of alpha.  If we instead had
-   [W] alpha ~ gamma1
-then we would unify alpha := gamma1; and kick out the wanted
-constraint.  But when we grough it back in, it'd look like
-   [W] TF (gamma1, beta) ~ fuv
-and exactly the same thing would happen again!  Infinite loop.
-
-This all seems fragile, and it might seem more robust to avoid
-introducing gamma1 in the first place, in the case where the
-actual argument (alpha, beta) partly matches the improvement
-template.  But that's a bit tricky, esp when we remember that the
-kinds much match too; so it's easier to let the normal machinery
-handle it.  Instead we are careful to orient the new
-equality with the template on the left.  Delicate, but it works.
-
--}
-
-{- *******************************************************************
-*                                                                    *
-         Top-level reaction for class constraints (CDictCan)
-*                                                                    *
-**********************************************************************-}
-
-doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct)
--- Try to use type-class instance declarations to simplify the constraint
-doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls
-                                          , cc_tyargs = xis })
-  | isGiven ev   -- Never use instances for Given constraints
-  = continueWith work_item
-     -- See Note [No Given/Given fundeps]
-
-  | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis   -- Cached
-  = do { setEvBindIfWanted ev IsCoherent (ctEvTerm solved_ev)
-       ; stopWith ev "Dict/Top (cached)" }
-
-  | otherwise  -- Wanted, but not cached
-   = do { dflags <- getDynFlags
-        ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc
-        ; case lkup_res of
-               OneInst { cir_what = what }
-                  -> do { insertSafeOverlapFailureTcS what work_item
-                        ; addSolvedDict what ev cls xis
-                        ; chooseInstance work_item lkup_res }
-               _  -> -- NoInstance or NotSure
-                     -- We didn't solve it; so try functional dependencies with
-                     -- the instance environment
-                     do { doTopFundepImprovement work_item
-                        ; tryLastResortProhibitedSuperclass inerts work_item } }
-   where
-     dict_loc = ctEvLoc ev
-
-
-doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)
-
--- | As a last resort, we TEMPORARILY allow a prohibited superclass solve,
--- emitting a loud warning when doing so: we might be creating non-terminating
--- evidence (as we are in T22912 for example).
---
--- See Note [Migrating away from loopy superclass solving] in GHC.Tc.TyCl.Instance.
-tryLastResortProhibitedSuperclass :: InertSet -> Ct -> TcS (StopOrContinue Ct)
-tryLastResortProhibitedSuperclass inerts
-    work_item@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = xis })
-  | let loc_w  = ctEvLoc ev_w
-        orig_w = ctLocOrigin loc_w
-  , ScOrigin _ NakedSc <- orig_w   -- work_item is definitely Wanted
-  , Just ct_i <- lookupInertDict (inert_cans inerts) loc_w cls xis
-  , let ev_i = ctEvidence ct_i
-  , isGiven ev_i
-  = do { setEvBindIfWanted ev_w IsCoherent (ctEvTerm ev_i)
-       ; ctLocWarnTcS loc_w $
-         TcRnLoopySuperclassSolve loc_w (ctPred work_item)
-       ; return $ Stop ev_w (text "Loopy superclass") }
-tryLastResortProhibitedSuperclass _ work_item
-  = continueWith work_item
-
-chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct)
-chooseInstance work_item
-               (OneInst { cir_new_theta   = theta
-                        , cir_what        = what
-                        , cir_mk_ev       = mk_ev
-                        , cir_coherence   = coherence })
-  = do { traceTcS "doTopReact/found instance for" $ ppr ev
-       ; deeper_loc <- checkInstanceOK loc what pred
-       ; checkReductionDepth deeper_loc pred
-       ; evb <- getTcEvBindsVar
-       ; if isCoEvBindsVar evb
-         then continueWith work_item
-                  -- See Note [Instances in no-evidence implications]
-         else
-           do { evc_vars <- mapM (newWanted deeper_loc (ctRewriters work_item)) theta
-              ; setEvBindIfWanted ev coherence (mk_ev (map getEvExpr evc_vars))
-              ; emitWorkNC (freshGoals evc_vars)
-              ; stopWith ev "Dict/Top (solved wanted)" }}
-  where
-     ev         = ctEvidence work_item
-     pred       = ctEvPred ev
-     loc        = ctEvLoc ev
-
-chooseInstance work_item lookup_res
-  = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)
-
-checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
--- Check that it's OK to use this instance:
---    (a) the use is well staged in the Template Haskell sense
--- Returns the CtLoc to used for sub-goals
--- Probably also want to call checkReductionDepth
-checkInstanceOK loc what pred
-  = do { checkWellStagedDFun loc what pred
-       ; return deeper_loc }
-  where
-     deeper_loc = zap_origin (bumpCtLocDepth loc)
-     origin     = ctLocOrigin loc
-
-     zap_origin loc  -- After applying an instance we can set ScOrigin to
-                     -- NotNakedSc, so that prohibitedSuperClassSolve never fires
-                     -- See Note [Solving superclass constraints] in
-                     -- GHC.Tc.TyCl.Instance, (sc1).
-       | ScOrigin what _ <- origin
-       = setCtLocOrigin loc (ScOrigin what NotNakedSc)
-       | otherwise
-       = loc
-
-{- Note [Instances in no-evidence implications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In #15290 we had
-  [G] forall p q. Coercible p q => Coercible (m p) (m q))
-  [W] forall <no-ev> a. m (Int, IntStateT m a)
-                          ~R#
-                        m (Int, StateT Int m a)
-
-The Given is an ordinary quantified constraint; the Wanted is an implication
-equality that arises from
-  [W] (forall a. t1) ~R# (forall a. t2)
-
-But because the (t1 ~R# t2) is solved "inside a type" (under that forall a)
-we can't generate any term evidence.  So we can't actually use that
-lovely quantified constraint.  Alas!
-
-This test arranges to ignore the instance-based solution under these
-(rare) circumstances.   It's sad, but I  really don't see what else we can do.
--}
-
-
-matchClassInst :: DynFlags -> InertSet
-               -> Class -> [Type]
-               -> CtLoc -> TcS ClsInstResult
-matchClassInst dflags inerts clas tys loc
--- First check whether there is an in-scope Given that could
--- match this constraint.  In that case, do not use any instance
--- whether top level, or local quantified constraints.
--- See Note [Instance and Given overlap]
-  | not (xopt LangExt.IncoherentInstances dflags)
-  , not (naturallyCoherentClass clas)
-  , not (noMatchableGivenDicts inerts loc clas tys)
-  = do { traceTcS "Delaying instance application" $
-           vcat [ text "Work item=" <+> pprClassPred clas tys ]
-       ; return NotSure }
-
-  | otherwise
-  = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{'
-       ; local_res <- matchLocalInst pred loc
-       ; case local_res of
-           OneInst {} ->  -- See Note [Local instances and incoherence]
-                do { traceTcS "} matchClassInst local match" $ ppr local_res
-                   ; return local_res }
-
-           NotSure -> -- In the NotSure case for local instances
-                      -- we don't want to try global instances
-                do { traceTcS "} matchClassInst local not sure" empty
-                   ; return local_res }
-
-           NoInstance  -- No local instances, so try global ones
-              -> do { global_res <- matchGlobalInst dflags False clas tys
-                    ; traceTcS "} matchClassInst global result" $ ppr global_res
-                    ; return global_res } }
-  where
-    pred = mkClassPred clas tys
-
--- | If a class is "naturally coherent", then we needn't worry at all, in any
--- way, about overlapping/incoherent instances. Just solve the thing!
--- See Note [Naturally coherent classes]
--- See also Note [The equality types story] in GHC.Builtin.Types.Prim.
-naturallyCoherentClass :: Class -> Bool
-naturallyCoherentClass cls
-  = isCTupleClass cls
-    || cls `hasKey` heqTyConKey
-    || cls `hasKey` eqTyConKey
-    || cls `hasKey` coercibleTyConKey
-
-
-{- Note [Instance and Given overlap]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Example, from the OutsideIn(X) paper:
-       instance P x => Q [x]
-       instance (x ~ y) => R y [x]
-
-       wob :: forall a b. (Q [b], R b a) => a -> Int
-
-       g :: forall a. Q [a] => [a] -> Int
-       g x = wob x
-
-From 'g' we get the implication constraint:
-            forall a. Q [a] => (Q [beta], R beta [a])
-If we react (Q [beta]) with its top-level axiom, we end up with a
-(P beta), which we have no way of discharging. On the other hand,
-if we react R beta [a] with the top-level we get  (beta ~ a), which
-is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is
-now solvable by the given Q [a].
-
-The partial solution is that:
-  In matchClassInst (and thus in topReact), we return a matching
-  instance only when there is no Given in the inerts which is
-  unifiable to this particular dictionary.
-
-  We treat any meta-tyvar as "unifiable" for this purpose,
-  *including* untouchable ones.  But not skolems like 'a' in
-  the implication constraint above.
-
-The end effect is that, much as we do for overlapping instances, we
-delay choosing a class instance if there is a possibility of another
-instance OR a given to match our constraint later on. This fixes
-tickets #4981 and #5002.
-
-Other notes:
-
-* The check is done *first*, so that it also covers classes
-  with built-in instance solving, such as
-     - constraint tuples
-     - natural numbers
-     - Typeable
-
-* See also Note [What might equal later?] in GHC.Tc.Solver.InertSet.
-
-* The given-overlap problem is arguably not easy to appear in practice
-  due to our aggressive prioritization of equality solving over other
-  constraints, but it is possible. I've added a test case in
-  typecheck/should-compile/GivenOverlapping.hs
-
-* Another "live" example is #10195; another is #10177.
-
-* We ignore the overlap problem if -XIncoherentInstances is in force:
-  see #6002 for a worked-out example where this makes a
-  difference.
-
-* Moreover notice that our goals here are different than the goals of
-  the top-level overlapping checks. There we are interested in
-  validating the following principle:
-
-      If we inline a function f at a site where the same global
-      instance environment is available as the instance environment at
-      the definition site of f then we should get the same behaviour.
-
-  But for the Given Overlap check our goal is just related to completeness of
-  constraint solving.
-
-* The solution is only a partial one.  Consider the above example with
-       g :: forall a. Q [a] => [a] -> Int
-       g x = let v = wob x
-             in v
-  and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most
-  general type for 'v'.  When generalising v's type we'll simplify its
-  Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we
-  will use the instance declaration after all. #11948 was a case
-  in point.
-
-All of this is disgustingly delicate, so to discourage people from writing
-simplifiable class givens, we warn about signatures that contain them;
-see GHC.Tc.Validity Note [Simplifiable given constraints].
-
-Note [Naturally coherent classes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A few built-in classes are "naturally coherent".  This term means that
-the "instance" for the class is bidirectional with its superclass(es).
-For example, consider (~~), which behaves as if it was defined like
-this:
-  class a ~# b => a ~~ b
-  instance a ~# b => a ~~ b
-(See Note [The equality types story] in GHC.Builtin.Types.Prim.)
-
-Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2,
-without worrying about Note [Instance and Given overlap].  Why?  Because
-if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and
-so the reduction of the [W] constraint does not risk losing any solutions.
-
-On the other hand, it can be fatal to /fail/ to reduce such
-equalities, on the grounds of Note [Instance and Given overlap],
-because many good things flow from [W] t1 ~# t2.
-
-The same reasoning applies to
-
-* (~~)        heqTyCon
-* (~)         eqTyCon
-* Coercible   coercibleTyCon
-
-And less obviously to:
-
-* Tuple classes.  For reasons described in GHC.Tc.Solver.Types
-  Note [Tuples hiding implicit parameters], we may have a constraint
-     [W] (?x::Int, C a)
-  with an exactly-matching Given constraint.  We must decompose this
-  tuple and solve the components separately, otherwise we won't solve
-  it at all!  It is perfectly safe to decompose it, because again the
-  superclasses invert the instance;  e.g.
-      class (c1, c2) => (% c1, c2 %)
-      instance (c1, c2) => (% c1, c2 %)
-  Example in #14218
-
-Examples: T5853, T10432, T5315, T9222, T2627b, T3028b
-
-PS: the term "naturally coherent" doesn't really seem helpful.
-Perhaps "invertible" or something?  I left it for now though.
-
-Note [Local instances and incoherence]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   f :: forall b c. (Eq b, forall a. Eq a => Eq (c a))
-                 => c b -> Bool
-   f x = x==x
-
-We get [W] Eq (c b), and we must use the local instance to solve it.
-
-BUT that wanted also unifies with the top-level Eq [a] instance,
-and Eq (Maybe a) etc.  We want the local instance to "win", otherwise
-we can't solve the wanted at all.  So we mark it as Incohherent.
-According to Note [Rules for instance lookup] in GHC.Core.InstEnv, that'll
-make it win even if there are other instances that unify.
-
-Moreover this is not a hack!  The evidence for this local instance
-will be constructed by GHC at a call site... from the very instances
-that unify with it here.  It is not like an incoherent user-written
-instance which might have utterly different behaviour.
-
-Consider  f :: Eq a => blah.  If we have [W] Eq a, we certainly
-get it from the Eq a context, without worrying that there are
-lots of top-level instances that unify with [W] Eq a!  We'll use
-those instances to build evidence to pass to f. That's just the
-nullary case of what's happening here.
--}
-
-matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult
--- Look up the predicate in Given quantified constraints,
--- which are effectively just local instance declarations.
-matchLocalInst pred loc
-  = do { inerts@(IS { inert_cans = ics }) <- getTcSInerts
-       ; case match_local_inst inerts (inert_insts ics) of
-          { ([], []) -> do { traceTcS "No local instance for" (ppr pred)
-                           ; return NoInstance }
-          ; (matches, unifs) ->
-    do { matches <- mapM mk_instDFun matches
-       ; unifs   <- mapM mk_instDFun unifs
-         -- See Note [Use only the best matching quantified constraint]
-       ; case dominatingMatch matches of
-          { Just (dfun_id, tys, theta)
-            | all ((theta `impliedBySCs`) . thdOf3) unifs
-            ->
-            do { let result = OneInst { cir_new_theta   = theta
-                                      , cir_mk_ev       = evDFunApp dfun_id tys
-                                      , cir_coherence   = IsCoherent
-                                      , cir_what        = LocalInstance }
-               ; traceTcS "Best local instance found:" $
-                  vcat [ text "pred:" <+> ppr pred
-                       , text "result:" <+> ppr result
-                       , text "matches:" <+> ppr matches
-                       , text "unifs:" <+> ppr unifs ]
-               ; return result }
-
-          ; mb_best ->
-            do { traceTcS "Multiple local instances; not committing to any"
-                  $ vcat [ text "pred:" <+> ppr pred
-                         , text "matches:" <+> ppr matches
-                         , text "unifs:" <+> ppr unifs
-                         , text "best_match:" <+> ppr mb_best ]
-               ; return NotSure }}}}}
-  where
-    pred_tv_set = tyCoVarsOfType pred
-
-    mk_instDFun :: (CtEvidence, [DFunInstType]) -> TcS InstDFun
-    mk_instDFun (ev, tys) =
-      let dfun_id = ctEvEvId ev
-      in do { (tys, theta) <- instDFunType (ctEvEvId ev) tys
-            ; return (dfun_id, tys, theta) }
-
-    -- Compute matching and unifying local instances
-    match_local_inst :: InertSet
-                     -> [QCInst]
-                     -> ( [(CtEvidence, [DFunInstType])]
-                        , [(CtEvidence, [DFunInstType])] )
-    match_local_inst _inerts []
-      = ([], [])
-    match_local_inst inerts (qci@(QCI { qci_tvs  = qtvs
-                                      , qci_pred = qpred
-                                      , qci_ev   = qev })
-                            :qcis)
-      | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set)
-      , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope)
-                                        emptyTvSubstEnv qpred pred
-      , let match = (qev, map (lookupVarEnv tv_subst) qtvs)
-      = (match:matches, unifs)
-
-      | otherwise
-      = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred))
-                  (ppr qci $$ ppr pred)
-            -- ASSERT: unification relies on the
-            -- quantified variables being fresh
-        (matches, this_unif `combine` unifs)
-      where
-        qloc = ctEvLoc qev
-        qtv_set = mkVarSet qtvs
-        (matches, unifs) = match_local_inst inerts qcis
-        this_unif
-          | Just subst <- mightEqualLater inerts qpred qloc pred loc
-          = Just (qev, map  (lookupTyVar subst) qtvs)
-          | otherwise
-          = Nothing
-
-        combine Nothing  us = us
-        combine (Just u) us = u : us
-
--- | Instance dictionary function and type.
-type InstDFun = (DFunId, [TcType], TcThetaType)
-
--- | Try to find a local quantified instance that dominates all others,
--- i.e. which has a weaker instance context than all the others.
---
--- See Note [Use only the best matching quantified constraint].
-dominatingMatch :: [InstDFun] -> Maybe InstDFun
-dominatingMatch matches =
-  listToMaybe $ mapMaybe (uncurry go) (holes matches)
-  -- listToMaybe: arbitrarily pick any one context that is weaker than
-  -- all others, e.g. so that we can handle [Eq a, Num a] vs [Num a, Eq a]
-  -- (see test case T22223).
-
-  where
-    go :: InstDFun -> [InstDFun] -> Maybe InstDFun
-    go this [] = Just this
-    go this@(_,_,this_theta) ((_,_,other_theta):others)
-      | this_theta `impliedBySCs` other_theta
-      = go this others
-      | otherwise
-      = Nothing
-
--- | Whether a collection of constraints is implied by another collection,
--- according to a simple superclass check.
---
--- See Note [When does a quantified instance dominate another?].
-impliedBySCs :: TcThetaType -> TcThetaType -> Bool
-impliedBySCs c1 c2 = all in_c2 c1
-  where
-    in_c2 :: TcPredType -> Bool
-    in_c2 pred = any (pred `tcEqType`) c2_expanded
-
-    c2_expanded :: [TcPredType]  -- Includes all superclasses
-    c2_expanded = [ q | p <- c2, q <- p : transSuperClasses p ]
-
-
-{- Note [When does a quantified instance dominate another?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When matching local quantified instances, it's useful to be able to pick
-the one with the weakest precondition, e.g. if one has both
-
-  [G] d1: forall a b. ( Eq a, Num b, C a b  ) => D a b
-  [G] d2: forall a  .                C a Int  => D a Int
-  [W] {w}: D a Int
-
-Then it makes sense to use d2 to solve w, as doing so we end up with a strictly
-weaker proof obligation of `C a Int`, compared to `(Eq a, Num Int, C a Int)`
-were we to use d1.
-
-In theory, to compute whether one context implies another, we would need to
-recursively invoke the constraint solver. This is expensive, so we instead do
-a simple check using superclasses, implemented in impliedBySCs.
-
-Examples:
-
- - [Eq a] is implied by [Ord a]
- - [Ord a] is not implied by [Eq a],
- - any context is implied by itself,
- - the empty context is implied by any context.
-
-Note [Use only the best matching quantified constraint]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#20582) the ambiguity check for
-  (forall a. Ord (m a), forall a. Semigroup a => Eq (m a)) => m Int
-
-Because of eager expansion of given superclasses, we get
-  [G] d1: forall a. Ord (m a)
-  [G] d2: forall a. Eq (m a)
-  [G] d3: forall a. Semigroup a => Eq (m a)
-
-  [W] {w1}: forall a. Ord (m a)
-  [W] {w2}: forall a. Semigroup a => Eq (m a)
-
-The first wanted is solved straightforwardly. But the second wanted
-matches *two* local instances: d2 and d3. Our general rule around multiple local
-instances is that we refuse to commit to any of them. However, that
-means that our type fails the ambiguity check. That's bad: the type
-is perfectly fine. (This actually came up in the wild, in the streamly
-library.)
-
-The solution is to prefer local instances which are easier to prove, meaning
-that they have a weaker precondition. In this case, the empty context
-of d2 is a weaker constraint than the "Semigroup a" context of d3, so we prefer
-using it when proving w2. This allows us to pass the ambiguity check here.
-
-Our criterion for solving a Wanted by matching local quantified instances is
-thus as follows:
-
-  - There is a matching local quantified instance that dominates all others
-    matches, in the sense of [When does a quantified instance dominate another?].
-    Any such match do, we pick it arbitrarily (the T22223 example below says why).
-  - This local quantified instance also dominates all the unifiers, as we
-    wouldn't want to commit to a single match when we might have multiple,
-    genuinely different matches after further unification takes place.
-
-Some other examples:
-
-
-  #15244:
-
-    f :: (C g, D g) => ....
-    class S g => C g where ...
-    class S g => D g where ...
-    class (forall a. Eq a => Eq (g a)) => S g where ...
-
-  Here, in f's RHS, there are two identical quantified constraints
-  available, one via the superclasses of C and one via the superclasses
-  of D. Given that each implies the other, we pick one arbitrarily.
-
-
-  #22216:
-
-    class Eq a
-    class Eq a => Ord a
-    class (forall b. Eq b => Eq (f b)) => Eq1 f
-    class (Eq1 f, forall b. Ord b => Ord (f b)) => Ord1 f
-
-  Suppose we have
-
-    [G] d1: Ord1 f
-    [G] d2: Eq a
-    [W] {w}: Eq (f a)
-
-  Superclass expansion of d1 gives us:
-
-    [G] d3 : Eq1 f
-    [G] d4 : forall b. Ord b => Ord (f b)
-
-  expanding d4 and d5 gives us, respectively:
-
-    [G] d5 : forall b. Eq  b => Eq (f b)
-    [G] d6 : forall b. Ord b => Eq (f b)
-
-  Now we have two matching local instances that we could use when solving the
-  Wanted. However, it's obviously silly to use d6, given that d5 provides us with
-  as much information, with a strictly weaker precondition. So we pick d5 to solve
-  w. If we chose d6, we would get [W] Ord a, which in this case we can't solve.
-
-
-  #22223:
-
-    [G] forall a b. (Eq a, Ord b) => C a b
-    [G] forall a b. (Ord b, Eq a) => C a b
-    [W] C x y
-
-  Here we should be free to pick either quantified constraint, as they are
-  equivalent up to re-ordering of the constraints in the context.
-  See also Note [Do not add duplicate quantified instances]
-  in GHC.Tc.Solver.Monad.
-
-Test cases:
-  typecheck/should_compile/T20582
-  quantified-constraints/T15244
-  quantified-constraints/T22216{a,b,c,d,e}
-  quantified-constraints/T22223
-
-Historical note: a previous solution was to instead pick the local instance
-with the least superclass depth (see Note [Replacement vs keeping]),
-but that doesn't work for the example from #22216.
--}
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 73eea460bc..19b3f5089b 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -19,6 +19,7 @@ module GHC.Tc.Solver.Monad (
     runTcSEqualities,
     nestTcS, nestImplicTcS, setEvBindsTcS,
     emitImplicationTcS, emitTvImplicationTcS,
+    emitFunDepWanteds,
 
     selectNextWorkItem,
     getWorkList,
@@ -30,6 +31,9 @@ module GHC.Tc.Solver.Monad (
 
     QCInst(..),
 
+    -- The pipeline
+    StopOrContinue(..), continueWith, stopWith, andWhenContinue,
+
     -- Tracing etc
     panicTcS, traceTcS,
     traceFireTcS, bumpStepCountTcS, csTraceTcS,
@@ -86,7 +90,11 @@ module GHC.Tc.Solver.Monad (
     lookupFamAppInert, lookupFamAppCache, extendFamAppCache,
     pprKicked,
 
-    instDFunType,                              -- Instantiation
+    -- Instantiation
+    instDFunType,
+
+    -- Unification
+    unifyWanted, unifyWanteds,
 
     -- MetaTyVars
     newFlexiTcSTy, instFlexiX,
@@ -135,15 +143,21 @@ import qualified GHC.Tc.Utils.Env      as TcM
 import GHC.Driver.Session
 
 import GHC.Tc.Instance.Class( safeOverlap, instanceReturnsDictCon )
+import GHC.Tc.Instance.FunDeps( FunDepEqn(..) )
 import GHC.Tc.Utils.TcType
 import GHC.Tc.Solver.Types
 import GHC.Tc.Solver.InertSet
 import GHC.Tc.Types.Evidence
 import GHC.Tc.Errors.Types
+import GHC.Tc.Types
+import GHC.Tc.Types.Origin
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Utils.Unify
 
 import GHC.Core.Type
-import qualified GHC.Core.TyCo.Rep as Rep  -- this needs to be used only very locally
+import GHC.Core.TyCo.Rep as Rep
 import GHC.Core.Coercion
+import GHC.Core.Predicate
 import GHC.Core.Reduction
 import GHC.Core.Class
 import GHC.Core.TyCon
@@ -152,36 +166,73 @@ import GHC.Types.Error ( mkPlainError, noHints )
 import GHC.Types.Name
 import GHC.Types.TyThing
 import GHC.Types.Name.Reader
+import GHC.Types.Var
+import GHC.Types.Var.Set
+import GHC.Types.Unique.Supply
+import GHC.Types.Unique.Set (nonDetEltsUniqSet)
 
 import GHC.Unit.Module ( HasModule, getModule, extractModule )
 import qualified GHC.Rename.Env as TcM
-import GHC.Types.Var
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
+
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Logger
 import GHC.Utils.Misc (HasDebugCallStack)
+
 import GHC.Data.Bag as Bag
-import GHC.Types.Unique.Supply
-import GHC.Tc.Types
-import GHC.Tc.Types.Origin
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Utils.Unify
-import GHC.Core.Predicate
-import GHC.Types.Unique.Set (nonDetEltsUniqSet)
+import GHC.Data.Pair
 
-import Control.Monad
 import GHC.Utils.Monad
-import Data.IORef
+import GHC.Utils.Misc( equalLength )
+
 import GHC.Exts (oneShot)
-import Data.List ( mapAccumL, partition )
+import Control.Monad
+import Data.IORef
+import Data.List ( mapAccumL, partition, zip4 )
 import Data.Foldable
+import qualified Data.Semigroup as S
 
 #if defined(DEBUG)
 import GHC.Data.Graph.Directed
 #endif
 
+
+{- *********************************************************************
+*                                                                      *
+                   StopOrContinue
+*                                                                      *
+********************************************************************* -}
+
+data StopOrContinue a
+  = ContinueWith a    -- The constraint was not solved, although it may have
+                      --   been rewritten
+
+  | Stop CtEvidence   -- The (rewritten) constraint was solved
+         SDoc         -- Tells how it was solved
+                      -- Any new sub-goals have been put on the work list
+  deriving (Functor)
+
+instance Outputable a => Outputable (StopOrContinue a) where
+  ppr (Stop ev s)      = text "Stop" <> parens s <+> ppr ev
+  ppr (ContinueWith w) = text "ContinueWith" <+> ppr w
+
+continueWith :: a -> TcS (StopOrContinue a)
+continueWith = return . ContinueWith
+
+stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)
+stopWith ev s = return (Stop ev (text s))
+
+andWhenContinue :: TcS (StopOrContinue a)
+                -> (a -> TcS (StopOrContinue b))
+                -> TcS (StopOrContinue b)
+andWhenContinue tcs1 tcs2
+  = do { r <- tcs1
+       ; case r of
+           Stop ev s       -> return (Stop ev s)
+           ContinueWith ct -> tcs2 ct }
+infixr 0 `andWhenContinue`    -- allow chaining with ($)
+
+
 {- *********************************************************************
 *                                                                      *
                    Inert instances: inert_insts
@@ -288,7 +339,7 @@ addInertCan ct =
 maybeKickOut :: InertCans -> Ct -> TcS InertCans
 -- For a CEqCan, kick out any inert that can be rewritten by the CEqCan
 maybeKickOut ics ct
-  | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct
+  | CEqCan (EqCt { eq_lhs = lhs, eq_ev = ev, eq_eq_rel = eq_rel }) <- ct
   = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics
        ; return ics' }
 
@@ -353,7 +404,7 @@ kickOutAfterUnification :: TcTyVar -> TcS Int
 kickOutAfterUnification new_tv
   = do { ics <- getInertCans
        ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)
-                                                 (TyVarLHS new_tv) ics
+                                               (TyVarLHS new_tv) ics
                      -- Given because the tv := xi is given; NomEq because
                      -- only nominal equalities are solved by unification
 
@@ -385,14 +436,13 @@ kickOutAfterFillingCoercionHole hole
       where
         (eqs_to_kick, eqs_to_keep)       = partitionInertEqs kick_ct eqs
         (funeqs_to_kick, funeqs_to_keep) = partitionFunEqs kick_ct funeqs
-        kicked_out = extendWorkListCts (eqs_to_kick ++ funeqs_to_kick) emptyWorkList
+        kicked_out = extendWorkListCts (map CEqCan (eqs_to_kick ++ funeqs_to_kick)) emptyWorkList
 
-    kick_ct :: Ct -> Bool
+    kick_ct :: EqCt -> Bool
          -- True: kick out; False: keep.
-    kick_ct (CEqCan { cc_rhs = rhs, cc_ev = ctev })
+    kick_ct (EqCt { eq_rhs = rhs, eq_ev = ctev })
       = isWanted ctev &&    -- optimisation: givens don't have coercion holes anyway
         rhs `hasThisCoercionHoleTy` hole
-    kick_ct other = pprPanic "kick_ct (coercion hole)" (ppr other)
 
 --------------
 addInertSafehask :: InertCans -> Ct -> InertCans
@@ -507,9 +557,10 @@ getInertGivens :: TcS [Ct]
 getInertGivens
   = do { inerts <- getInertCans
        ; let all_cts = foldIrreds (:) (inert_irreds inerts)
-                     $ foldDicts (:) (inert_dicts inerts)
-                     $ foldFunEqs (++) (inert_funeqs inerts)
-                     $ foldDVarEnv (++) [] (inert_eqs inerts)
+                     $ foldDicts  (:) (inert_dicts inerts)
+                     $ foldFunEqs ((:) . CEqCan) (inert_funeqs inerts)
+                     $ foldTyEqs  ((:) . CEqCan) (inert_eqs inerts)
+                     $ []
        ; return (filter isGivenCt all_cts) }
 
 getPendingGivenScs :: TcS [Ct]
@@ -581,8 +632,8 @@ getUnsolvedInerts
            , inert_dicts   = idicts
            } <- getInertCans
 
-      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts
-            unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts
+      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved_eq tv_eqs emptyCts
+            unsolved_fun_eqs = foldFunEqs add_if_unsolved_eq fun_eqs emptyCts
             unsolved_irreds  = Bag.filterBag isWantedCt irreds
             unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts
             unsolved_others  = unionManyBags [ unsolved_irreds
@@ -604,8 +655,9 @@ getUnsolvedInerts
     add_if_unsolved ct cts | isWantedCt ct = ct `consCts` cts
                            | otherwise     = cts
 
-    add_if_unsolveds :: EqualCtList -> Cts -> Cts
-    add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts new_cts
+    add_if_unsolved_eq :: EqCt -> Cts -> Cts
+    add_if_unsolved_eq eq_ct cts | isWanted (eq_ev eq_ct) = CEqCan eq_ct `consCts` cts
+                                 | otherwise              = cts
 
 getHasGivenEqs :: TcLevel           -- TcLevel of this implication
                -> TcS ( HasGivenEqs -- are there Given equalities?
@@ -650,7 +702,7 @@ removeInertCt is ct =
     CDictCan  { cc_class = cl, cc_tyargs = tys } ->
       is { inert_dicts = delDict (inert_dicts is) cl tys }
 
-    CEqCan    { cc_lhs  = lhs, cc_rhs = rhs } -> delEq is lhs rhs
+    CEqCan    eq_ct  -> delEq is eq_ct
 
     CIrredCan {}     -> is { inert_irreds = filterBag (not . eqCt ct) $ inert_irreds is }
 
@@ -670,8 +722,8 @@ lookupFamAppInert rewrite_pred fam_tc tys
   where
     lookup_inerts inert_funeqs
       | Just ecl <- findFunEq inert_funeqs fam_tc tys
-      , Just (CEqCan { cc_ev = ctev, cc_rhs = rhs })
-          <- find (rewrite_pred . ctFlavourRole) ecl
+      , Just (EqCt { eq_ev = ctev, eq_rhs = rhs })
+          <- find (rewrite_pred . eqCtFlavourRole) ecl
       = Just (mkReduction (ctEvCoercion ctev) rhs, ctEvFlavourRole ctev)
       | otherwise = Nothing
 
@@ -1913,6 +1965,174 @@ solverDepthError loc ty
       , text " minor updates to GHC, so disabling the check is recommended if"
       , text " you're sure that type checking should terminate)" ]
 
+{-
+************************************************************************
+*                                                                      *
+              Emitting equalities arising from fundeps
+*                                                                      *
+************************************************************************
+-}
+
+emitFunDepWanteds :: RewriterSet  -- from the work item
+                  -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS ()
+
+emitFunDepWanteds _ [] = return () -- common case noop
+-- See Note [FunDep and implicit parameter reactions]
+
+emitFunDepWanteds work_rewriters fd_eqns
+  = mapM_ do_one_FDEqn fd_eqns
+  where
+    do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) })
+     | null tvs  -- Common shortcut
+     = do { traceTcS "emitFunDepWanteds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))
+          ; mapM_ (\(Pair ty1 ty2) -> unifyWanted all_rewriters loc Nominal ty1 ty2)
+                  (reverse eqs) }
+             -- See Note [Reverse order of fundep equations]
+
+     | otherwise
+     = do { traceTcS "emitFunDepWanteds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)
+          ; subst <- instFlexiX emptySubst tvs  -- Takes account of kind substitution
+          ; mapM_ (do_one_eq loc all_rewriters subst) (reverse eqs) }
+               -- See Note [Reverse order of fundep equations]
+     where
+       all_rewriters = work_rewriters S.<> rewriters
+
+    do_one_eq loc rewriters subst (Pair ty1 ty2)
+       = unifyWanted rewriters loc Nominal (substTyUnchecked subst' ty1) ty2
+         -- ty2 does not mention fd_qtvs, so no need to subst it.
+         -- See GHC.Tc.Instance.Fundeps Note [Improving against instances]
+         --     Wrinkle (1)
+      where
+         subst' = extendSubstInScopeSet subst (tyCoVarsOfType ty1)
+         -- The free vars of ty1 aren't just fd_qtvs: ty1 is the result
+         -- of matching with the [W] constraint. So we add its free
+         -- vars to InScopeSet, to satisfy substTy's invariants, even
+         -- though ty1 will never (currently) be a poytype, so this
+         -- InScopeSet will never be looked at.
+
+
+{-
+************************************************************************
+*                                                                      *
+              Unification
+*                                                                      *
+************************************************************************
+
+Note [unifyWanted]
+~~~~~~~~~~~~~~~~~~
+When decomposing equalities we often create new wanted constraints for
+(s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.
+
+Rather than making an equality test (which traverses the structure of the
+type, perhaps fruitlessly), unifyWanted traverses the common structure, and
+bales out when it finds a difference by creating a new Wanted constraint.
+But where it succeeds in finding common structure, it just builds a coercion
+to reflect it.
+-}
+
+unifyWanted :: RewriterSet -> CtLoc
+            -> Role -> TcType -> TcType -> TcS Coercion
+-- Return coercion witnessing the equality of the two types,
+-- emitting new work equalities where necessary to achieve that
+-- Very good short-cut when the two types are equal, or nearly so
+-- See Note [unifyWanted]
+-- The returned coercion's role matches the input parameter
+unifyWanted rewriters loc Phantom ty1 ty2
+  = do { kind_co <- unifyWanted rewriters loc Nominal (typeKind ty1) (typeKind ty2)
+       ; return (mkPhantomCo kind_co ty1 ty2) }
+
+unifyWanted rewriters loc role orig_ty1 orig_ty2
+  = go orig_ty1 orig_ty2
+  where
+    go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2
+    go ty1 ty2 | Just ty2' <- coreView ty2 = go ty1 ty2'
+
+    go (FunTy af1 w1 s1 t1) (FunTy af2 w2 s2 t2)
+      | af1 == af2    -- Important!  See #21530
+      = do { co_s <- unifyWanted rewriters loc role s1 s2
+           ; co_t <- unifyWanted rewriters loc role t1 t2
+           ; co_w <- unifyWanted rewriters loc Nominal w1 w2
+           ; return (mkNakedFunCo1 role af1 co_w co_s co_t) }
+
+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+      | tc1 == tc2, tys1 `equalLength` tys2
+      , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality
+      = do { cos <- zipWith3M (unifyWanted rewriters loc)
+                              (tyConRoleListX role tc1) tys1 tys2
+           ; return (mkTyConAppCo role tc1 cos) }
+
+    go ty1@(TyVarTy tv) ty2
+      = do { mb_ty <- isFilledMetaTyVar_maybe tv
+           ; case mb_ty of
+                Just ty1' -> go ty1' ty2
+                Nothing   -> bale_out ty1 ty2}
+    go ty1 ty2@(TyVarTy tv)
+      = do { mb_ty <- isFilledMetaTyVar_maybe tv
+           ; case mb_ty of
+                Just ty2' -> go ty1 ty2'
+                Nothing   -> bale_out ty1 ty2 }
+
+    go ty1@(CoercionTy {}) (CoercionTy {})
+      = return (mkReflCo role ty1) -- we just don't care about coercions!
+
+    go ty1 ty2 = bale_out ty1 ty2
+
+    bale_out ty1 ty2
+       | ty1 `tcEqType` ty2 = return (mkReflCo role ty1)
+        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)
+       | otherwise = emitNewWantedEq loc rewriters role orig_ty1 orig_ty2
+
+
+{-
+Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we decompose a dependent tycon we obtain a list of
+mixed wanted type and kind equalities. Ideally we want
+all the kind equalities to get solved first so that we avoid
+generating duplicate kind equalities
+
+For example, consider decomposing a TyCon equality
+
+    (0) [W] T k_fresh (t1::k_fresh) ~ T k1 (t2::k_fresh)
+
+This gives rise to 2 equalities in the solver worklist
+
+    (1) [W] k_fresh ~ k1
+    (2) [W] t1::k_fresh ~ t2::k1
+
+The solver worklist is processed in LIFO order:
+see GHC.Tc.Solver.InertSet.selectWorkItem.
+i.e. (2) is processed _before_ (1). Now, while solving (2)
+we would call `canEqCanLHSHetero` and that would emit a
+wanted kind equality
+
+    (3) [W] k_fresh ~ k1
+
+But (3) is exactly the same as (1)!
+
+To avoid such duplicate wanted constraints from being added to the worklist,
+we ensure that (2) is processed before (1). Since we are processing
+the worklist in a LIFO ordering, we do it by emitting (1) before (2).
+This is exactly what we do in `unifyWanteds`.
+
+NB: This ordering is not needed when we decompose FunTyCons as they are not dependently typed
+-}
+
+-- NB: Length of [CtLoc] and [Roles] may be infinite
+-- but list of RHS [TcType] and LHS [TcType] is finite and both are of equal length
+unifyWanteds :: RewriterSet -> [CtLoc] -> [Role]
+             -> [TcType] -- List of RHS types
+             -> [TcType] -- List of LHS types
+             -> TcS [Coercion]
+unifyWanteds rewriters ctlocs roles rhss lhss = unify_wanteds rewriters $ zip4 ctlocs roles rhss lhss
+  where
+    -- Order is important here
+    -- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
+    unify_wanteds _ [] = return []
+    unify_wanteds rewriters ((new_loc, tc_role, ty1, ty2) : rest)
+       = do { cos <- unify_wanteds rewriters rest
+            ; co  <- unifyWanted rewriters new_loc tc_role ty1 ty2
+            ; return (co:cos) }
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs
index 16ab2471b3..6508a21420 100644
--- a/compiler/GHC/Tc/Solver/Rewrite.hs
+++ b/compiler/GHC/Tc/Solver/Rewrite.hs
@@ -1012,9 +1012,9 @@ rewrite_tyvar2 tv fr@(_, eq_rel)
        ; case lookupDVarEnv ieqs tv of
            Just equal_ct_list
              | Just ct <- find can_rewrite equal_ct_list
-             , CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv
-                      , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct
-             -> do { let wrw = isWantedCt ct
+             , EqCt { eq_ev = ctev, eq_lhs = TyVarLHS tv
+                    , eq_rhs = rhs_ty, eq_eq_rel = ct_eq_rel } <- ct
+             -> do { let wrw = isWanted ctev
                    ; traceRewriteM "Following inert tyvar" $
                         vcat [ ppr tv <+> equals <+> ppr rhs_ty
                              , ppr ctev
@@ -1035,8 +1035,8 @@ rewrite_tyvar2 tv fr@(_, eq_rel)
            _other -> return RTRNotFollowed }
 
   where
-    can_rewrite :: Ct -> Bool
-    can_rewrite ct = ctFlavourRole ct `eqCanRewriteFR` fr
+    can_rewrite :: EqCt -> Bool
+    can_rewrite ct = eqCtFlavourRole ct `eqCanRewriteFR` fr
       -- This is THE key call of eqCanRewriteFR
 
 {-
diff --git a/compiler/GHC/Tc/Solver/Types.hs b/compiler/GHC/Tc/Solver/Types.hs
index e6ee09b0d8..80ca1113a6 100644
--- a/compiler/GHC/Tc/Solver/Types.hs
+++ b/compiler/GHC/Tc/Solver/Types.hs
@@ -8,7 +8,7 @@ module GHC.Tc.Solver.Types (
     addDictsByClass, delDict, foldDicts, filterDicts, findDict,
     dictsToBag, partitionDicts,
 
-    FunEqMap, emptyFunEqs, foldFunEqs, findFunEq, insertFunEq,
+    FunEqMap, emptyFunEqs, findFunEq, insertFunEq,
     findFunEqsByTyCon,
 
     TcAppMap, emptyTcAppMap, isEmptyTcAppMap,
@@ -16,6 +16,7 @@ module GHC.Tc.Solver.Types (
     tcAppMapToBag, foldTcAppMap,
 
     EqualCtList, filterEqualCtList, addToEqualCtList
+
   ) where
 
 import GHC.Prelude
@@ -241,12 +242,10 @@ findFunEqsByTyCon m tc
   | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm []
   | otherwise                       = []
 
-foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b
-foldFunEqs = foldTcAppMap
-
 insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
 insertFunEq m tc tys val = insertTcApp m tc tys val
 
+
 {- *********************************************************************
 *                                                                      *
                    EqualCtList
@@ -264,15 +263,15 @@ Accordingly, this list is either empty, contains one element, or
 contains a Given representational equality and a Wanted nominal one.
 -}
 
-type EqualCtList = [Ct]
+type EqualCtList = [EqCt]
   -- See Note [EqualCtList invariants]
 
-addToEqualCtList :: Ct -> EqualCtList -> EqualCtList
+addToEqualCtList :: EqCt -> EqualCtList -> EqualCtList
 -- See Note [EqualCtList invariants]
 addToEqualCtList ct old_eqs
   | debugIsOn
   = case ct of
-      CEqCan { cc_lhs = TyVarLHS tv } ->
+      EqCt { eq_lhs = TyVarLHS tv } ->
         assert (all (shares_lhs tv) old_eqs) $
         assertPpr (null bad_prs)
                   (vcat [ text "bad_prs" <+> ppr bad_prs
@@ -284,10 +283,11 @@ addToEqualCtList ct old_eqs
   | otherwise
   = ct : old_eqs
   where
-    shares_lhs tv (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv
+    shares_lhs tv (EqCt { eq_lhs = TyVarLHS old_tv }) = tv == old_tv
     shares_lhs _ _ = False
     bad_prs = filter is_bad_pair (distinctPairs (ct : old_eqs))
-    is_bad_pair (ct1,ct2) = ctFlavourRole ct1 `eqCanRewriteFR` ctFlavourRole ct2
+    is_bad_pair :: (EqCt, EqCt) -> Bool
+    is_bad_pair (ct1,ct2) = eqCtFlavourRole ct1 `eqCanRewriteFR` eqCtFlavourRole ct2
 
 distinctPairs :: [a] -> [(a,a)]
 -- distinctPairs [x1,...xn] is the list of all pairs [ ...(xi, xj)...]
@@ -298,7 +298,7 @@ distinctPairs []     = []
 distinctPairs (x:xs) = concatMap (\y -> [(x,y),(y,x)]) xs ++ distinctPairs xs
 
 -- returns Nothing when the new list is empty, to keep the environments smaller
-filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList
+filterEqualCtList :: (EqCt -> Bool) -> EqualCtList -> Maybe EqualCtList
 filterEqualCtList pred cts
   | null new_list
   = Nothing
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index e3e7057bfa..bf710f0fe9 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -1655,7 +1655,7 @@ Answer:
     origin.  But if we apply an instance declaration, we can set the
     origin to (ScOrigin NotNakedSc), thus lifting any restrictions by
     making prohibitedSuperClassSolve return False. This happens
-    in GHC.Tc.Solver.Interact.checkInstanceOK.
+    in GHC.Tc.Solver.Dict.checkInstanceOK.
 
   * (sc2) ScOrigin wanted constraints can't be solved from a
     superclass selection, except at a smaller type.  This test is
diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs
index 7d4911263f..a2e84ab7dc 100644
--- a/compiler/GHC/Tc/Types/Constraint.hs
+++ b/compiler/GHC/Tc/Types/Constraint.hs
@@ -10,12 +10,9 @@ module GHC.Tc.Types.Constraint (
         QCInst(..), pendingScInst_maybe,
 
         -- Canonical constraints
-        Xi, Ct(..), Cts,
-        ExpansionFuel, doNotExpand, consumeFuel, pendingFuel,
-        assertFuelPrecondition, assertFuelPreconditionStrict,
-        emptyCts, andCts, andManyCts, pprCts,
+        Xi, Ct(..), EqCt(..), Cts,
         singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
-        isEmptyCts, ctsPreds,
+        isEmptyCts, emptyCts, andCts, ctsPreds,
         isPendingScDict, pendingScDict_maybe,
         superClassesMightHelp, getPendingWantedScs,
         isWantedCt, isGivenCt,
@@ -31,6 +28,9 @@ module GHC.Tc.Types.Constraint (
         tyCoVarsOfCt, tyCoVarsOfCts,
         tyCoVarsOfCtList, tyCoVarsOfCtsList,
 
+        ExpansionFuel, doNotExpand, consumeFuel, pendingFuel,
+        assertFuelPrecondition, assertFuelPreconditionStrict,
+
         CtIrredReason(..), isInsolubleReason,
 
         CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck,
@@ -83,7 +83,7 @@ module GHC.Tc.Types.Constraint (
         wrapType,
 
         CtFlavour(..), ctEvFlavour,
-        CtFlavourRole, ctEvFlavourRole, ctFlavourRole,
+        CtFlavourRole, ctEvFlavourRole, ctFlavourRole, eqCtFlavourRole,
         eqCanRewrite, eqCanRewriteFR,
 
         -- Pretty printing
@@ -252,40 +252,45 @@ data Ct
         --    a ~ [a]         occurs check
     }
 
-  | CEqCan {  -- CanEqLHS ~ rhs
-       -- Invariants:
-       --   * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet
-       --   * Many are checked in checkTypeEq in GHC.Tc.Utils.Unify
-       --   * (TyEq:OC) lhs does not occur in rhs (occurs check)
-       --               Note [CEqCan occurs check]
-       --   * (TyEq:F) rhs has no foralls
-       --       (this avoids substituting a forall for the tyvar in other types)
-       --   * (TyEq:K) typeKind lhs `tcEqKind` typeKind rhs; Note [Ct kind invariant]
-       --   * (TyEq:N) If the equality is representational, rhs is not headed by a saturated
-       --     application of a newtype TyCon.
-       --     See Note [No top-level newtypes on RHS of representational equalities]
-       --     in GHC.Tc.Solver.Canonical. (Applies only when constructor of newtype is
-       --     in scope.)
-       --   * (TyEq:TV) If rhs (perhaps under a cast) is also CanEqLHS, then it is oriented
-       --     to give best chance of
-       --     unification happening; eg if rhs is touchable then lhs is too
-       --     Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify
-      cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]
-      cc_lhs    :: CanEqLHS,
-      cc_rhs    :: Xi,         -- See invariants above
-
-      cc_eq_rel :: EqRel       -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev
-    }
-
   | CNonCanonical {        -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad
       cc_ev  :: CtEvidence
     }
 
+  | CEqCan EqCt         -- A canonical equality constraint
+
   | CQuantCan QCInst       -- A quantified constraint
       -- NB: I expect to make more of the cases in Ct
       --     look like this, with the payload in an
       --     auxiliary type
 
+{- Note [Invariants of EqCt]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An EqCt carries a canonical equality constraint, that satisfies these invariants:
+  * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet
+  * Many are checked in checkTypeEq in GHC.Tc.Utils.Unify
+  * (TyEq:OC) lhs does not occur in rhs (occurs check)
+              Note [CEqCan occurs check]
+  * (TyEq:F) rhs has no foralls
+      (this avoids substituting a forall for the tyvar in other types)
+  * (TyEq:K) typeKind lhs `tcEqKind` typeKind rhs; Note [Ct kind invariant]
+  * (TyEq:N) If the equality is representational, rhs is not headed by a saturated
+    application of a newtype TyCon.
+    See Note [No top-level newtypes on RHS of representational equalities]
+    in GHC.Tc.Solver.Canonical. (Applies only when constructor of newtype is
+    in scope.)
+  * (TyEq:TV) If rhs (perhaps under a cast) is also CanEqLHS, then it is oriented
+    to give best chance of unification happening; eg if rhs is touchable then lhs is too
+    Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify
+-}
+
+data EqCt -- An equality constraint; see Note [Invariants of EqCt]
+  = EqCt {  -- CanEqLHS ~ rhs
+      eq_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]
+      eq_lhs    :: CanEqLHS,
+      eq_rhs    :: Xi,         -- See invariants above
+      eq_eq_rel :: EqRel       -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev
+    }
+
 ------------
 -- | A 'CanEqLHS' is a type that can appear on the left of a canonical
 -- equality: a type variable or exactly-saturated type family application.
@@ -653,7 +658,8 @@ mkGivens loc ev_ids
 
 ctEvidence :: Ct -> CtEvidence
 ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev
-ctEvidence ct = cc_ev ct
+ctEvidence (CEqCan (EqCt { eq_ev = ev }))    = ev
+ctEvidence ct                                = cc_ev ct
 
 ctLoc :: Ct -> CtLoc
 ctLoc = ctEvLoc . ctEvidence
@@ -717,6 +723,9 @@ instance Outputable Ct where
             | psc > 0  -> text "CQuantCan"  <> parens (text "psc" <+> ppr psc)
             | otherwise -> text "CQuantCan"
 
+instance Outputable EqCt where
+  ppr (EqCt { eq_ev = ev }) = ppr ev
+
 -----------------------------------
 -- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated
 -- type family application?
@@ -1034,9 +1043,6 @@ extendCtsList :: Cts -> [Ct] -> Cts
 extendCtsList cts xs | null xs   = cts
                      | otherwise = cts `unionBags` listToBag xs
 
-andManyCts :: [Cts] -> Cts
-andManyCts = unionManyBags
-
 emptyCts :: Cts
 emptyCts = emptyBag
 
@@ -1046,9 +1052,6 @@ isEmptyCts = isEmptyBag
 ctsPreds :: Cts -> [PredType]
 ctsPreds cts = foldr ((:) . ctPred) [] cts
 
-pprCts :: Cts -> SDoc
-pprCts cts = vcat (map ppr (bagToList cts))
-
 {-
 ************************************************************************
 *                                                                      *
@@ -2087,14 +2090,16 @@ ctEvFlavourRole :: CtEvidence -> CtFlavourRole
 ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev)
 
 -- | Extract the flavour and role from a 'Ct'
+eqCtFlavourRole :: EqCt -> CtFlavourRole
+eqCtFlavourRole (EqCt { eq_ev = ev, eq_eq_rel = eq_rel })
+  = (ctEvFlavour ev, eq_rel)
+
+-- | Extract the flavour and role from a 'Ct'
 ctFlavourRole :: Ct -> CtFlavourRole
 -- Uses short-cuts to role for special cases
-ctFlavourRole (CDictCan { cc_ev = ev })
-  = (ctEvFlavour ev, NomEq)
-ctFlavourRole (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })
-  = (ctEvFlavour ev, eq_rel)
-ctFlavourRole ct
-  = ctEvFlavourRole (ctEvidence ct)
+ctFlavourRole (CDictCan { cc_ev = ev }) = (ctEvFlavour ev, NomEq)
+ctFlavourRole (CEqCan eq_ct)            = eqCtFlavourRole eq_ct
+ctFlavourRole ct                        = ctEvFlavourRole (ctEvidence ct)
 
 {- Note [eqCanRewrite]
 ~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index 9536f58a58..e3ca947cdd 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -2423,7 +2423,7 @@ zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args })
        ; args' <- mapM zonkTcType args
        ; return $ ct { cc_ev = ev', cc_tyargs = args' } }
 
-zonkCt (CEqCan { cc_ev = ev })
+zonkCt (CEqCan (EqCt { eq_ev = ev }))
   = mkNonCanonical <$> zonkCtEvidence ev
 
 zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_reason flag
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 74384caf49..2cf8c04bff 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -721,6 +721,8 @@ Library
         GHC.Tc.Solver.Rewrite
         GHC.Tc.Solver.InertSet
         GHC.Tc.Solver.Interact
+        GHC.Tc.Solver.Equality
+        GHC.Tc.Solver.Dict
         GHC.Tc.Solver.Monad
         GHC.Tc.Solver.Types
         GHC.Tc.TyCl
diff --git a/testsuite/tests/linters/notes.stdout b/testsuite/tests/linters/notes.stdout
index edf75f2d77..0a8b2161fe 100644
--- a/testsuite/tests/linters/notes.stdout
+++ b/testsuite/tests/linters/notes.stdout
@@ -1,63 +1,61 @@
-ref    compiler/GHC/Core/Coercion/Axiom.hs:461:2:     Note [RoughMap and rm_empty]
-ref    compiler/GHC/Core/Opt/OccurAnal.hs:857:15:     Note [Loop breaking]
-ref    compiler/GHC/Core/Opt/SetLevels.hs:1580:30:     Note [Top level scope]
-ref    compiler/GHC/Core/Opt/Simplify/Iteration.hs:2675:13:     Note [Case binder next]
-ref    compiler/GHC/Core/Opt/Simplify/Iteration.hs:3854:8:     Note [Lambda-bound unfoldings]
-ref    compiler/GHC/Core/Opt/Simplify/Utils.hs:1257:37:     Note [Gentle mode]
-ref    compiler/GHC/Core/Opt/Specialise.hs:1623:28:     Note [Arity decrease]
-ref    compiler/GHC/Core/TyCo/Rep.hs:1748:31:     Note [What prevents a constraint from floating]
-ref    compiler/GHC/Driver/Main.hs:1641:34:     Note [simpleTidyPgm - mkBootModDetailsTc]
-ref    compiler/GHC/Driver/Session.hs:3961:49:     Note [Eta-reduction in -O0]
+ref    compiler/GHC/Core/Coercion/Axiom.hs:463:2:     Note [RoughMap and rm_empty]
+ref    compiler/GHC/Core/Opt/OccurAnal.hs:983:7:     Note [Loop breaking]
+ref    compiler/GHC/Core/Opt/SetLevels.hs:1574:30:     Note [Top level scope]
+ref    compiler/GHC/Core/Opt/Simplify/Iteration.hs:2825:13:     Note [Case binder next]
+ref    compiler/GHC/Core/Opt/Simplify/Iteration.hs:4009:8:     Note [Lambda-bound unfoldings]
+ref    compiler/GHC/Core/Opt/Simplify/Utils.hs:1343:37:     Note [Gentle mode]
+ref    compiler/GHC/Core/Opt/Specialise.hs:1790:28:     Note [Arity decrease]
+ref    compiler/GHC/Core/TyCo/Rep.hs:1556:31:     Note [What prevents a constraint from floating]
+ref    compiler/GHC/Driver/Main.hs:1761:34:     Note [simpleTidyPgm - mkBootModDetailsTc]
+ref    compiler/GHC/Driver/Session.hs:3976:49:     Note [Eta-reduction in -O0]
 ref    compiler/GHC/Hs/Expr.hs:191:63:     Note [Pending Splices]
-ref    compiler/GHC/Hs/Expr.hs:1704:87:     Note [Lifecycle of a splice]
-ref    compiler/GHC/Hs/Expr.hs:1740:7:     Note [Pending Splices]
-ref    compiler/GHC/Hs/Extension.hs:144:5:     Note [Strict argument type constraints]
+ref    compiler/GHC/Hs/Expr.hs:1706:87:     Note [Lifecycle of a splice]
+ref    compiler/GHC/Hs/Expr.hs:1742:7:     Note [Pending Splices]
+ref    compiler/GHC/Hs/Extension.hs:146:5:     Note [Strict argument type constraints]
 ref    compiler/GHC/Hs/Pat.hs:143:74:     Note [Lifecycle of a splice]
-ref    compiler/GHC/HsToCore/Pmc/Solver.hs:854:20:     Note [COMPLETE sets on data families]
-ref    compiler/GHC/HsToCore/Quote.hs:1460:7:     Note [How brackets and nested splices are handled]
-ref    compiler/GHC/Rename/Pat.hs:888:29:     Note [Disambiguating record fields]
-ref    compiler/GHC/Stg/Unarise.hs:313:32:     Note [Renaming during unarisation]
+ref    compiler/GHC/HsToCore/Pmc/Solver.hs:858:20:     Note [COMPLETE sets on data families]
+ref    compiler/GHC/HsToCore/Quote.hs:1476:7:     Note [How brackets and nested splices are handled]
+ref    compiler/GHC/Rename/Pat.hs:890:29:     Note [Disambiguating record fields]
+ref    compiler/GHC/Stg/Unarise.hs:442:32:     Note [Renaming during unarisation]
 ref    compiler/GHC/StgToCmm.hs:106:18:     Note [codegen-split-init]
 ref    compiler/GHC/StgToCmm.hs:109:18:     Note [pipeline-split-init]
-ref    compiler/GHC/StgToCmm/Expr.hs:584:4:     Note [case on bool]
-ref    compiler/GHC/StgToCmm/Expr.hs:848:3:     Note [alg-alt heap check]
-ref    compiler/GHC/Tc/Gen/Expr.hs:1207:23:     Note [Disambiguating record fields]
-ref    compiler/GHC/Tc/Gen/Expr.hs:1422:7:     Note [Disambiguating record fields]
-ref    compiler/GHC/Tc/Gen/Expr.hs:1525:11:     Note [Deprecating ambiguous fields]
-ref    compiler/GHC/Tc/Gen/HsType.hs:551:56:     Note [Skolem escape prevention]
-ref    compiler/GHC/Tc/Gen/HsType.hs:2619:7:     Note [Matching a kind signature with a declaration]
-ref    compiler/GHC/Tc/Gen/Pat.hs:171:20:     Note [Typing patterns in pattern bindings]
-ref    compiler/GHC/Tc/Gen/Pat.hs:1101:7:     Note [Matching polytyped patterns]
-ref    compiler/GHC/Tc/Gen/Sig.hs:79:10:     Note [Overview of type signatures]
+ref    compiler/GHC/StgToCmm/Expr.hs:585:4:     Note [case on bool]
+ref    compiler/GHC/StgToCmm/Expr.hs:853:3:     Note [alg-alt heap check]
+ref    compiler/GHC/Tc/Gen/Expr.hs:1212:23:     Note [Disambiguating record fields]
+ref    compiler/GHC/Tc/Gen/Expr.hs:1427:7:     Note [Disambiguating record fields]
+ref    compiler/GHC/Tc/Gen/Expr.hs:1530:11:     Note [Deprecating ambiguous fields]
+ref    compiler/GHC/Tc/Gen/HsType.hs:557:56:     Note [Skolem escape prevention]
+ref    compiler/GHC/Tc/Gen/HsType.hs:2622:7:     Note [Matching a kind signature with a declaration]
+ref    compiler/GHC/Tc/Gen/Pat.hs:176:20:     Note [Typing patterns in pattern bindings]
+ref    compiler/GHC/Tc/Gen/Pat.hs:1127:7:     Note [Matching polytyped patterns]
+ref    compiler/GHC/Tc/Gen/Sig.hs:81:10:     Note [Overview of type signatures]
 ref    compiler/GHC/Tc/Gen/Splice.hs:359:16:     Note [How brackets and nested splices are handled]
 ref    compiler/GHC/Tc/Gen/Splice.hs:534:35:     Note [PendingRnSplice]
 ref    compiler/GHC/Tc/Gen/Splice.hs:658:7:     Note [How brackets and nested splices are handled]
-ref    compiler/GHC/Tc/Gen/Splice.hs:897:11:     Note [How brackets and nested splices are handled]
-ref    compiler/GHC/Tc/Instance/Family.hs:515:35:     Note [Constrained family instances]
-ref    compiler/GHC/Tc/Module.hs:704:15:     Note [Extra dependencies from .hs-boot files]
-ref    compiler/GHC/Tc/Solver/Canonical.hs:1087:33:     Note [Canonical LHS]
-ref    compiler/GHC/Tc/Solver/Interact.hs:1611:9:     Note [No touchables as FunEq RHS]
-ref    compiler/GHC/Tc/Solver/Rewrite.hs:988:7:     Note [Stability of rewriting]
-ref    compiler/GHC/Tc/TyCl.hs:1106:6:     Note [Unification variables need fresh Names]
-ref    compiler/GHC/Tc/Types.hs:703:33:     Note [Extra dependencies from .hs-boot files]
-ref    compiler/GHC/Tc/Types.hs:1434:47:     Note [Care with plugin imports]
-ref    compiler/GHC/Tc/Types/Constraint.hs:253:34:     Note [NonCanonical Semantics]
-ref    compiler/GHC/Types/Demand.hs:308:25:     Note [Preserving Boxity of results is rarely a win]
-ref    compiler/GHC/Unit/Module/Deps.hs:82:13:     Note [Structure of dep_boot_mods]
-ref    compiler/GHC/Utils/Monad.hs:391:34:     Note [multiShotIO]
-ref    compiler/Language/Haskell/Syntax/Binds.hs:204:31:     Note [fun_id in Match]
-ref    compiler/Language/Haskell/Syntax/Pat.hs:336:12:     Note [Disambiguating record fields]
-ref    configure.ac:212:10:     Note [Linking ghc-bin against threaded stage0 RTS]
+ref    compiler/GHC/Tc/Gen/Splice.hs:891:11:     Note [How brackets and nested splices are handled]
+ref    compiler/GHC/Tc/Instance/Family.hs:474:35:     Note [Constrained family instances]
+ref    compiler/GHC/Tc/Module.hs:708:15:     Note [Extra dependencies from .hs-boot files]
+ref    compiler/GHC/Tc/Solver/Rewrite.hs:1008:7:     Note [Stability of rewriting]
+ref    compiler/GHC/Tc/TyCl.hs:1119:6:     Note [Unification variables need fresh Names]
+ref    compiler/GHC/Tc/Types.hs:697:33:     Note [Extra dependencies from .hs-boot files]
+ref    compiler/GHC/Tc/Types.hs:1428:47:     Note [Care with plugin imports]
+ref    compiler/GHC/Tc/Types/Constraint.hs:223:34:     Note [NonCanonical Semantics]
+ref    compiler/GHC/Types/Demand.hs:306:25:     Note [Preserving Boxity of results is rarely a win]
+ref    compiler/GHC/Unit/Module/Deps.hs:81:13:     Note [Structure of dep_boot_mods]
+ref    compiler/GHC/Utils/Monad.hs:400:34:     Note [multiShotIO]
+ref    compiler/Language/Haskell/Syntax/Binds.hs:200:31:     Note [fun_id in Match]
+ref    compiler/Language/Haskell/Syntax/Pat.hs:356:12:     Note [Disambiguating record fields]
+ref    configure.ac:210:10:     Note [Linking ghc-bin against threaded stage0 RTS]
 ref    docs/core-spec/core-spec.mng:177:6:     Note [TyBinders]
-ref    hadrian/src/Expression.hs:130:30:     Note [Linking ghc-bin against threaded stage0 RTS]
+ref    hadrian/src/Expression.hs:134:30:     Note [Linking ghc-bin against threaded stage0 RTS]
 ref    linters/lint-notes/Notes.hs:32:29:     Note [" <> T.unpack x <> "]
 ref    linters/lint-notes/Notes.hs:69:22:     Note [...]
-ref    testsuite/config/ghc:243:10:     Note [WayFlags]
-ref    testsuite/driver/testlib.py:153:10:     Note [Why is there no stage1 setup function?]
-ref    testsuite/driver/testlib.py:157:2:     Note [Why is there no stage1 setup function?]
+ref    testsuite/config/ghc:272:10:     Note [WayFlags]
+ref    testsuite/driver/testlib.py:160:10:     Note [Why is there no stage1 setup function?]
+ref    testsuite/driver/testlib.py:164:2:     Note [Why is there no stage1 setup function?]
 ref    testsuite/mk/boilerplate.mk:267:2:     Note [WayFlags]
 ref    testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.hs:30:27:     Note [Extra TcS Untouchables]
-ref    testsuite/tests/perf/should_run/all.T:3:6:     Note [Solving from instances when interacting Dicts]
+ref    testsuite/tests/perf/should_run/all.T:8:6:     Note [Solving from instances when interacting Dicts]
 ref    testsuite/tests/polykinds/CuskFam.hs:16:11:     Note [Unifying implicit CUSK variables]
 ref    testsuite/tests/simplCore/should_compile/T5776.hs:16:7:     Note [Simplifying RULE lhs constraints]
 ref    testsuite/tests/simplCore/should_compile/simpl018.hs:3:7:     Note [Float coercions]