diff --git a/compiler/GHC/Cmm/Dataflow/Label.hs b/compiler/GHC/Cmm/Dataflow/Label.hs
index 161125daffbc1c1321f25f0ad93c2e9675f9c73a..a9a74fd50e8e79a061709ad37a1bac95767d0fe1 100644
--- a/compiler/GHC/Cmm/Dataflow/Label.hs
+++ b/compiler/GHC/Cmm/Dataflow/Label.hs
@@ -141,6 +141,7 @@ instance TrieMap LabelMap where
   alterTM k f m = mapAlter f k m
   foldTM k m z = mapFoldr k z m
   mapTM f m = mapMap f m
+  filterTM f m = mapFilter f m
 
 -----------------------------------------------------------------------------
 -- FactBase
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs
index 4413c7355b6732a72ef07774852761379cdabf02..051f415572710e9c1187093b159c1d21189a5a05 100644
--- a/compiler/GHC/Core/Coercion.hs
+++ b/compiler/GHC/Core/Coercion.hs
@@ -13,8 +13,8 @@
 --
 module GHC.Core.Coercion (
         -- * Main data type
-        Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR,
-        UnivCoProvenance, CoercionHole(..), BlockSubstFlag(..),
+        Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionN, MCoercionR,
+        UnivCoProvenance, CoercionHole(..),
         coHoleCoVar, setCoHoleCoVar,
         LeftOrRight(..),
         Var, CoVar, TyCoVar,
@@ -69,8 +69,10 @@ module GHC.Core.Coercion (
         pickLR,
 
         isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,
-        isReflCoVar_maybe, isGReflMCo,
-        coToMCo, mkTransMCo, mkTransMCoL,
+        isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo,
+        mkCoherenceRightMCo,
+
+        coToMCo, mkTransMCo, mkTransMCoL, mkCastTyMCo, mkSymMCo, isReflMCo,
 
         -- ** Coercion variables
         mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,
@@ -79,7 +81,7 @@ module GHC.Core.Coercion (
         -- ** Free variables
         tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,
         tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,
-        coercionSize,
+        coercionSize, anyFreeVarsOfCo,
 
         -- ** Substitution
         CvSubstEnv, emptyCvSubstEnv,
@@ -121,7 +123,8 @@ module GHC.Core.Coercion (
 
         simplifyArgsWorker,
 
-        badCoercionHole, badCoercionHoleCo
+        hasCoercionHoleTy, hasCoercionHoleCo,
+        HoleSet, coercionHolesOfType, coercionHolesOfCo
        ) where
 
 #include "HsVersions.h"
@@ -154,6 +157,7 @@ import GHC.Builtin.Types.Prim
 import GHC.Data.List.SetOps
 import GHC.Data.Maybe
 import GHC.Types.Unique.FM
+import GHC.Types.Unique.Set
 
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
@@ -331,6 +335,32 @@ mkTransMCoL :: MCoercion -> Coercion -> MCoercion
 mkTransMCoL MRefl     co2 = MCo co2
 mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2)
 
+-- | Get the reverse of an 'MCoercion'
+mkSymMCo :: MCoercion -> MCoercion
+mkSymMCo MRefl    = MRefl
+mkSymMCo (MCo co) = MCo (mkSymCo co)
+
+-- | Cast a type by an 'MCoercion'
+mkCastTyMCo :: Type -> MCoercion -> Type
+mkCastTyMCo ty MRefl    = ty
+mkCastTyMCo ty (MCo co) = ty `mkCastTy` co
+
+mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion
+mkGReflLeftMCo r ty MRefl    = mkReflCo r ty
+mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co
+
+mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion
+mkGReflRightMCo r ty MRefl    = mkReflCo r ty
+mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co
+
+-- | Like 'mkCoherenceRightCo', but with an 'MCoercion'
+mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion
+mkCoherenceRightMCo _ _  MRefl    co2 = co2
+mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2
+
+isReflMCo :: MCoercion -> Bool
+isReflMCo MRefl = True
+isReflMCo _     = False
 
 {-
 %************************************************************************
@@ -1219,7 +1249,7 @@ mkKindCo co
   | otherwise
   = KindCo co
 
-mkSubCo :: Coercion -> Coercion
+mkSubCo :: HasDebugCallStack => Coercion -> Coercion
 -- Input coercion is Nominal, result is Representational
 -- see also Note [Role twiddling functions]
 mkSubCo (Refl ty) = GRefl Representational ty MRefl
@@ -1675,6 +1705,11 @@ data NormaliseStepResult ev
                                     -- ^ ev is evidence;
                                     -- Usually a co :: old type ~ new type
 
+instance Outputable ev => Outputable (NormaliseStepResult ev) where
+  ppr NS_Done           = text "NS_Done"
+  ppr NS_Abort          = text "NS_Abort"
+  ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev]
+
 mapStepResult :: (ev1 -> ev2)
               -> NormaliseStepResult ev1 -> NormaliseStepResult ev2
 mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev)
@@ -2634,7 +2669,8 @@ FamInstEnv, and so lives here.
 
 Note [simplifyArgsWorker]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
-Invariant (F2) of Note [Flattening] says that flattening is homogeneous.
+Invariant (F2) of Note [Flattening] in GHC.Tc.Solver.Flatten says that
+flattening is homogeneous.
 This causes some trouble when flattening a function applied to a telescope
 of arguments, perhaps with dependency. For example, suppose
 
@@ -2913,7 +2949,7 @@ simplifyArgsWorker :: [TyCoBinder] -> Kind
                    -> [(Type, Coercion)] -- flattened type arguments, arg
                                          -- each comes with the coercion used to flatten it,
                                          -- with co :: flattened_type ~ original_type
-                   -> ([Type], [Coercion], CoercionN)
+                   -> ([Type], [Coercion], MCoercionN)
 -- Returns (xis, cos, res_co), where each co :: xi ~ arg,
 -- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args
 -- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in),
@@ -2935,14 +2971,15 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
        -> Kind        -- Unsubsted result kind of function (not a Pi-type)
        -> [Role]      -- Roles at which to flatten these ...
        -> [(Type, Coercion)]  -- flattened arguments, with their flattening coercions
-       -> ([Type], [Coercion], CoercionN)
+       -> ([Type], [Coercion], MCoercionN)
     go acc_xis acc_cos !lc binders inner_ki _ []
         -- The !lc makes the function strict in the lifting context
         -- which means GHC can unbox that pair.  A modest win.
       = (reverse acc_xis, reverse acc_cos, kind_co)
       where
         final_kind = mkPiTys binders inner_ki
-        kind_co = liftCoSubst Nominal lc final_kind
+        kind_co | noFreeVarsOfType final_kind = MRefl
+                | otherwise                   = MCo $ liftCoSubst Nominal lc final_kind
 
     go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args)
       = -- By Note [Flattening] in GHC.Tc.Solver.Flatten invariant (F2),
@@ -2998,7 +3035,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
             (xis_out, cos_out, res_co_out)
               = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args
         in
-        (xis_out, cos_out, res_co_out `mkTransCo` res_co)
+        (xis_out, cos_out, res_co_out `mkTransMCoL` res_co)
 
     go _ _ _ _ _ _ _ = panic
         "simplifyArgsWorker wandered into deeper water than usual"
@@ -3024,31 +3061,40 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
 %************************************************************************
 -}
 
-bad_co_hole_ty :: Type -> Monoid.Any
-bad_co_hole_co :: Coercion -> Monoid.Any
-(bad_co_hole_ty, _, bad_co_hole_co, _)
+has_co_hole_ty :: Type -> Monoid.Any
+has_co_hole_co :: Coercion -> Monoid.Any
+(has_co_hole_ty, _, has_co_hole_co, _)
   = foldTyCo folder ()
   where
     folder = TyCoFolder { tcf_view  = const Nothing
                         , tcf_tyvar = const2 (Monoid.Any False)
                         , tcf_covar = const2 (Monoid.Any False)
-                        , tcf_hole  = const hole
+                        , tcf_hole  = const2 (Monoid.Any True)
                         , tcf_tycobinder = const2
                         }
 
     const2 :: a -> b -> c -> a
     const2 x _ _ = x
 
-    hole :: CoercionHole -> Monoid.Any
-    hole (CoercionHole { ch_blocker = YesBlockSubst }) = Monoid.Any True
-    hole _                                             = Monoid.Any False
+-- | Is there a coercion hole in this type?
+hasCoercionHoleTy :: Type -> Bool
+hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty
+
+-- | Is there a coercion hole in this coercion?
+hasCoercionHoleCo :: Coercion -> Bool
+hasCoercionHoleCo = Monoid.getAny . has_co_hole_co
 
--- | Is there a blocking coercion hole in this type? See
--- "GHC.Tc.Solver.Canonical" Note [Equalities with incompatible kinds]
-badCoercionHole :: Type -> Bool
-badCoercionHole = Monoid.getAny . bad_co_hole_ty
+-- | A set of 'CoercionHole's
+type HoleSet = UniqSet CoercionHole
 
--- | Is there a blocking coercion hole in this coercion? See
--- GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds]
-badCoercionHoleCo :: Coercion -> Bool
-badCoercionHoleCo = Monoid.getAny . bad_co_hole_co
+-- | Extract out all the coercion holes from a given type
+coercionHolesOfType :: Type -> UniqSet CoercionHole
+coercionHolesOfCo   :: Coercion -> UniqSet CoercionHole
+(coercionHolesOfType, _, coercionHolesOfCo, _) = foldTyCo folder ()
+  where
+    folder = TyCoFolder { tcf_view  = const Nothing  -- don't look through synonyms
+                        , tcf_tyvar = \ _ _ -> mempty
+                        , tcf_covar = \ _ _ -> mempty
+                        , tcf_hole  = const unitUniqSet
+                        , tcf_tycobinder = \ _ _ _ -> ()
+                        }
diff --git a/compiler/GHC/Core/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot
index 7a92a84eb617274bcfaf8efb445c1c7c6df054b8..0c18e5e68fd1c9c1183afa3b72f477deb408edc4 100644
--- a/compiler/GHC/Core/Coercion.hs-boot
+++ b/compiler/GHC/Core/Coercion.hs-boot
@@ -30,7 +30,7 @@ mkInstCo :: Coercion -> Coercion -> Coercion
 mkGReflCo :: Role -> Type -> MCoercionN -> Coercion
 mkNomReflCo :: Type -> Coercion
 mkKindCo :: Coercion -> Coercion
-mkSubCo :: Coercion -> Coercion
+mkSubCo :: HasDebugCallStack => Coercion -> Coercion
 mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion
 mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion
 
diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs
index ae7ae8971fcd16c15e071d718018ac5f4b419e36..46b238e678f65fa26c22e213ccb1c5313c8430c3 100644
--- a/compiler/GHC/Core/Coercion/Axiom.hs
+++ b/compiler/GHC/Core/Coercion/Axiom.hs
@@ -584,9 +584,21 @@ instance Outputable CoAxiomRule where
 -- Type checking of built-in families
 data BuiltInSynFamily = BuiltInSynFamily
   { sfMatchFam      :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+    -- Does this reduce on the given arguments?
+    -- If it does, returns (CoAxiomRule, types to instantiate the rule at, rhs type)
+    -- That is: mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)
+    --              :: F tys ~r rhs,
+    -- where the r in the output is coaxrRole of the rule. It is up to the
+    -- caller to ensure that this role is appropriate.
+
   , sfInteractTop   :: [Type] -> Type -> [TypeEqn]
+    -- If given these type arguments and RHS, returns the equalities that
+    -- are guaranteed to hold.
+
   , sfInteractInert :: [Type] -> Type ->
                        [Type] -> Type -> [TypeEqn]
+    -- If given one set of arguments and result, and another set of arguments
+    -- and result, returns the equalities that are guaranteed to hold.
   }
 
 -- Provides default implementations that do nothing.
diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs
index 3769fb23be3e39b4af7ae5ff2c7b009be54133c1..108154e1c647f12b2fdbfdbb0904890be9a96cf8 100644
--- a/compiler/GHC/Core/Coercion/Opt.hs
+++ b/compiler/GHC/Core/Coercion/Opt.hs
@@ -27,7 +27,6 @@ import GHC.Types.Var.Env
 import GHC.Data.Pair
 import GHC.Data.List.SetOps ( getNth )
 import GHC.Core.Unify
-import GHC.Core.InstEnv
 import Control.Monad   ( zipWithM )
 
 import GHC.Utils.Outputable
@@ -1006,7 +1005,7 @@ checkAxInstCo (AxiomInstCo ax ind cos)
     check_no_conflict _    [] = Nothing
     check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest)
          -- See Note [Apartness] in GHC.Core.FamInstEnv
-      | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp
+      | SurelyApart <- tcUnifyTysFG (const BindMe) flat lhs_incomp
       = check_no_conflict flat rest
       | otherwise
       = Just b
diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs
index c5445fceae2ffc42ef379e550ee093095fbf9231..a6c7604008a06b1861f8d6929431c91f270627ac 100644
--- a/compiler/GHC/Core/FamInstEnv.hs
+++ b/compiler/GHC/Core/FamInstEnv.hs
@@ -428,7 +428,8 @@ Here is how we do it:
 apart(target, pattern) = not (unify(flatten(target), pattern))
 
 where flatten (implemented in flattenTys, below) converts all type-family
-applications into fresh variables. (See Note [Flattening] in GHC.Core.Unify.)
+applications into fresh variables. (See
+Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.)
 
 Note [Compatibility]
 ~~~~~~~~~~~~~~~~~~~~
@@ -1141,6 +1142,7 @@ reduceTyFamApp_maybe envs role tc tys
 
   | Just ax           <- isBuiltInSynFamTyCon_maybe tc
   , Just (coax,ts,ty) <- sfMatchFam ax tys
+  , role == coaxrRole coax
   = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)
     in Just (co, ty)
 
@@ -1175,7 +1177,8 @@ findBranch branches target_tys
                         , cab_incomps = incomps }) = branch
             in_scope = mkInScopeSet (unionVarSets $
                             map (tyCoVarsOfTypes . coAxBranchLHS) incomps)
-            -- See Note [Flattening] in GHC.Core.Unify
+            -- See Note [Flattening type-family applications when matching instances]
+            -- in GHC.Core.Unify
             flattened_target = flattenTys in_scope target_tys
         in case tcMatchTys tpl_lhs target_tys of
         Just subst -- matching worked. now, check for apartness.
@@ -1192,11 +1195,11 @@ findBranch branches target_tys
 -- (POPL '14). This should be used when determining if an equation
 -- ('CoAxBranch') of a closed type family can be used to reduce a certain target
 -- type family application.
-apartnessCheck :: [Type]     -- ^ /flattened/ target arguments. Make sure
-                             -- they're flattened! See Note [Flattening]
-                             -- in GHC.Core.Unify
-                             -- (NB: This "flat" is a different
-                             -- "flat" than is used in GHC.Tc.Solver.Flatten.)
+apartnessCheck :: [Type]
+  -- ^ /flattened/ target arguments. Make sure they're flattened! See
+  -- Note [Flattening type-family applications when matching instances]
+  -- in GHC.Core.Unify. (NB: This "flat" is a different
+ -- "flat" than is used in GHC.Tc.Solver.Flatten.)
                -> CoAxBranch -- ^ the candidate equation we wish to use
                              -- Precondition: this matches the target
                -> Bool       -- ^ True <=> equation can fire
@@ -1316,7 +1319,7 @@ topNormaliseType_maybe env ty
     tyFamStepper :: NormaliseStepper (Coercion, MCoercionN)
     tyFamStepper rec_nts tc tys  -- Try to step a type/data family
       = case topReduceTyFamApp_maybe env tc tys of
-          Just (co, rhs, res_co) -> NS_Step rec_nts rhs (co, MCo res_co)
+          Just (co, rhs, res_co) -> NS_Step rec_nts rhs (co, res_co)
           _                      -> NS_Done
 
 ---------------
@@ -1362,14 +1365,14 @@ normalise_tc_app tc tys
     assemble_result :: Role       -- r, ambient role in NormM monad
                     -> Type       -- nty, result type, possibly of changed kind
                     -> Coercion   -- orig_ty ~r nty, possibly heterogeneous
-                    -> CoercionN  -- typeKind(orig_ty) ~N typeKind(nty)
+                    -> MCoercionN -- typeKind(orig_ty) ~N typeKind(nty)
                     -> (Coercion, Type)   -- (co :: orig_ty ~r nty_casted, nty_casted)
                                           -- where nty_casted has same kind as orig_ty
     assemble_result r nty orig_to_nty kind_co
       = ( final_co, nty_old_kind )
       where
-        nty_old_kind = nty `mkCastTy` mkSymCo kind_co
-        final_co     = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty
+        nty_old_kind = nty `mkCastTyMCo` mkSymMCo kind_co
+        final_co     = mkCoherenceRightMCo r nty (mkSymMCo kind_co) orig_to_nty
 
 ---------------
 -- | Try to simplify a type-family application, by *one* step
@@ -1378,7 +1381,7 @@ normalise_tc_app tc tys
 --         res_co :: typeKind(F tys) ~ typeKind(rhs)
 -- Type families and data families; always Representational role
 topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type]
-                        -> Maybe (Coercion, Type, Coercion)
+                        -> Maybe (Coercion, Type, MCoercion)
 topReduceTyFamApp_maybe envs fam_tc arg_tys
   | isFamilyTyCon fam_tc   -- type families and data families
   , Just (co, rhs) <- reduceTyFamApp_maybe envs role fam_tc ntys
@@ -1391,7 +1394,7 @@ topReduceTyFamApp_maybe envs fam_tc arg_tys
                               normalise_tc_args fam_tc arg_tys
 
 normalise_tc_args :: TyCon -> [Type]             -- tc tys
-                  -> NormM (Coercion, [Type], CoercionN)
+                  -> NormM (Coercion, [Type], MCoercionN)
                   -- (co, new_tys), where
                   -- co :: tc tys ~ tc new_tys; might not be homogeneous
                   -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys)
@@ -1474,14 +1477,14 @@ normalise_type ty
                     ; role <- getRole
                     ; let nty = mkAppTys nfun nargs
                           nco = mkAppCos fun_co args_cos
-                          nty_casted = nty `mkCastTy` mkSymCo res_co
-                          final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco
+                          nty_casted = nty `mkCastTyMCo` mkSymMCo res_co
+                          final_co = mkCoherenceRightMCo role nty (mkSymMCo res_co) nco
                     ; return (final_co, nty_casted) } }
 
 normalise_args :: Kind    -- of the function
                -> [Role]  -- roles at which to normalise args
                -> [Type]  -- args
-               -> NormM ([Coercion], [Type], Coercion)
+               -> NormM ([Coercion], [Type], MCoercion)
 -- returns (cos, xis, res_co), where each xi is the normalised
 -- version of the corresponding type, each co is orig_arg ~ xi,
 -- and the res_co :: kind(f orig_args) ~ kind(f xis)
@@ -1491,7 +1494,7 @@ normalise_args :: Kind    -- of the function
 normalise_args fun_ki roles args
   = do { normed_args <- zipWithM normalise1 roles args
        ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args
-       ; return (map mkSymCo cos, xis, mkSymCo res_co) }
+       ; return (map mkSymCo cos, xis, mkSymMCo res_co) }
   where
     (ki_binders, inner_ki) = splitPiTys fun_ki
     fvs = tyCoVarsOfTypes args
diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs
index e8603a4cae9abfe82ac18dde9ffabc3f2ed8137f..6eae14090ffa4c61e4dbe06de31b1fdce66f64d8 100644
--- a/compiler/GHC/Core/InstEnv.hs
+++ b/compiler/GHC/Core/InstEnv.hs
@@ -828,18 +828,22 @@ lookupInstEnv' ie vis_mods cls tys
       = find ms us rest
 
       | otherwise
-      = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set,
+      = ASSERT2( tys_tv_set `disjointVarSet` tpl_tv_set,
                  (ppr cls <+> ppr tys <+> ppr all_tvs) $$
                  (ppr tpl_tvs <+> ppr tpl_tys)
                 )
                 -- Unification will break badly if the variables overlap
                 -- They shouldn't because we allocate separate uniques for them
                 -- See Note [Template tyvars are fresh]
-        case tcUnifyTys instanceBindFun tpl_tys tys of
-            Just _   -> find ms (item:us) rest
-            Nothing  -> find ms us        rest
+        case tcUnifyTysFG instanceBindFun tpl_tys tys of
+          -- We consider MaybeApart to be a case where the instance might
+          -- apply in the future. This covers an instance like C Int and
+          -- a target like [W] C (F a), where F is a type family.
+            SurelyApart -> find ms us        rest
+            _           -> find ms (item:us) rest
       where
         tpl_tv_set = mkVarSet tpl_tvs
+        tys_tv_set = tyCoVarsOfTypes tys
 
 ---------------
 -- This is the common way to call this function.
@@ -1023,20 +1027,28 @@ When looking up in the instance environment, or family-instance environment,
 we are careful about multiple matches, as described above in
 Note [Overlapping instances]
 
-The key_tys can contain skolem constants, and we can guarantee that those
+The target tys can contain skolem constants. For existentials and instance variables,
+we can guarantee that those
 are never going to be instantiated to anything, so we should not involve
-them in the unification test.  Example:
+them in the unification test. These are called "super skolems". Example:
         class Foo a where { op :: a -> Int }
         instance Foo a => Foo [a]       -- NB overlap
         instance Foo [Int]              -- NB overlap
         data T = forall a. Foo a => MkT a
         f :: T -> Int
         f (MkT x) = op [x,x]
-The op [x,x] means we need (Foo [a]).  Without the filterVarSet we'd
-complain, saying that the choice of instance depended on the instantiation
-of 'a'; but of course it isn't *going* to be instantiated.
-
-We do this only for isOverlappableTyVar skolems.  For example we reject
+The op [x,x] means we need (Foo [a]). This `a` will never be instantiated, and
+so it is a super skolem. (See the use of tcInstSuperSkolTyVarsX in
+GHC.Tc.Gen.Pat.tcDataConPat.) Super skolems respond True to
+isOverlappableTyVar, and the use of Skolem in instanceBindFun, above, means
+that these will be treated as fresh constants in the unification algorithm
+during instance lookup. Without this treatment, GHC would complain, saying
+that the choice of instance depended on the instantiation of 'a'; but of
+course it isn't *going* to be instantiated. Note that it is necessary that
+the unification algorithm returns SurelyApart for these super-skolems
+for GHC to be able to commit to another instance.
+
+We do this only for super skolems.  For example we reject
         g :: forall a => [a] -> Int
         g x = op x
 on the grounds that the correct instance depends on the instantiation of 'a'
diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs
index b3273a1a2e9fd0c080127ba3f7568fecd81d9502..2181abb304966729bb2bd77dab8143747e308749 100644
--- a/compiler/GHC/Core/Map/Expr.hs
+++ b/compiler/GHC/Core/Map/Expr.hs
@@ -116,6 +116,7 @@ instance TrieMap CoreMap where
     alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)
     foldTM k (CoreMap m) = foldTM k m
     mapTM f (CoreMap m) = CoreMap (mapTM f m)
+    filterTM f (CoreMap m) = CoreMap (filterTM f m)
 
 -- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@.  The extended
 -- key makes it suitable for recursive traversal, since it can track binders,
@@ -197,6 +198,7 @@ instance TrieMap CoreMapX where
    alterTM  = xtE
    foldTM   = fdE
    mapTM    = mapE
+   filterTM = ftE
 
 --------------------------
 mapE :: (a->b) -> CoreMapX a -> CoreMapX b
@@ -213,6 +215,20 @@ mapE f (CM { cm_var = cvar, cm_lit = clit
        , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase
        , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }
 
+ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a
+ftE f (CM { cm_var = cvar, cm_lit = clit
+          , cm_co = cco, cm_type = ctype
+          , cm_cast = ccast , cm_app = capp
+          , cm_lam = clam, cm_letn = cletn
+          , cm_letr = cletr, cm_case = ccase
+          , cm_ecase = cecase, cm_tick = ctick })
+  = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit
+       , cm_co = filterTM f cco, cm_type = filterTM f ctype
+       , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp
+       , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn
+       , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase
+       , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick }
+
 --------------------------
 lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a
 lookupCoreMap cm e = lookupTM e cm
@@ -330,6 +346,7 @@ instance TrieMap AltMap where
    alterTM  = xtA emptyCME
    foldTM   = fdA
    mapTM    = mapA
+   filterTM = ftA
 
 instance Eq (DeBruijn CoreAlt) where
   D env1 a1 == D env2 a2 = go a1 a2 where
@@ -348,6 +365,12 @@ mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
        , am_data = mapTM (mapTM f) adata
        , am_lit = mapTM (mapTM f) alit }
 
+ftA :: (a->Bool) -> AltMap a -> AltMap a
+ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
+  = AM { am_deflt = filterTM f adeflt
+       , am_data = mapTM (filterTM f) adata
+       , am_lit = mapTM (filterTM f) alit }
+
 lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a
 lkA env (DEFAULT,    _, rhs)  = am_deflt >.> lkG (D env rhs)
 lkA env (LitAlt lit, _, rhs)  = am_lit >.> lookupTM lit >=> lkG (D env rhs)
diff --git a/compiler/GHC/Core/Map/Type.hs b/compiler/GHC/Core/Map/Type.hs
index 36583dc6708dc22a5bcdb76f7d80e9154e00ac58..8056211314f52d2d70e7cd2fa4a53dcccb3c4824 100644
--- a/compiler/GHC/Core/Map/Type.hs
+++ b/compiler/GHC/Core/Map/Type.hs
@@ -8,6 +8,9 @@
 {-# LANGUAGE TypeFamilies #-}
 
 module GHC.Core.Map.Type (
+     -- * Re-export generic interface
+   TrieMap(..),
+
      -- * Maps over 'Type's
    TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap,
    LooseTypeMap,
@@ -45,6 +48,7 @@ import GHC.Types.Var.Env
 import GHC.Types.Unique.FM
 import GHC.Utils.Outputable
 
+import GHC.Data.Maybe
 import GHC.Utils.Panic
 
 import qualified Data.Map    as Map
@@ -86,6 +90,7 @@ instance TrieMap CoercionMap where
    alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m)
    foldTM k    (CoercionMap m) = foldTM k m
    mapTM f     (CoercionMap m) = CoercionMap (mapTM f m)
+   filterTM f  (CoercionMap m) = CoercionMap (filterTM f m)
 
 type CoercionMapG = GenMap CoercionMapX
 newtype CoercionMapX a = CoercionMapX (TypeMapX a)
@@ -97,6 +102,7 @@ instance TrieMap CoercionMapX where
   alterTM  = xtC
   foldTM f (CoercionMapX core_tm) = foldTM f core_tm
   mapTM f (CoercionMapX core_tm)  = CoercionMapX (mapTM f core_tm)
+  filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm)
 
 instance Eq (DeBruijn Coercion) where
   D env1 co1 == D env2 co2
@@ -135,6 +141,12 @@ data TypeMapX a
   = TM { tm_var    :: VarMap a
        , tm_app    :: TypeMapG (TypeMapG a)
        , tm_tycon  :: DNameEnv a
+
+         -- only InvisArg arrows here
+       , tm_funty  :: TypeMapG (TypeMapG (TypeMapG a))
+                       -- keyed on the argument, result rep, and result
+                       -- constraints are never linear-restricted and are always lifted
+
        , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr
        , tm_tylit  :: TyLitMap a
        , tm_coerce :: Maybe a
@@ -142,10 +154,12 @@ data TypeMapX a
     -- Note that there is no tyconapp case; see Note [Equality on AppTys] in GHC.Core.Type
 
 -- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the
--- last one? See Note [Equality on AppTys] in "GHC.Core.Type"
+-- last one? See Note [Equality on AppTys] in GHC.Core.Type
 --
 -- Note, however, that we keep Constraint and Type apart here, despite the fact
 -- that they are both synonyms of TYPE 'LiftedRep (see #11715).
+--
+-- We also keep (Eq a => a) as a FunTy, distinct from ((->) (Eq a) a).
 trieMapView :: Type -> Maybe Type
 trieMapView ty
   -- First check for TyConApps that need to be expanded to
@@ -164,6 +178,7 @@ instance TrieMap TypeMapX where
    alterTM  = xtT
    foldTM   = fdT
    mapTM    = mapT
+   filterTM = filterT
 
 instance Eq (DeBruijn Type) where
   env_t@(D env t) == env_t'@(D env' t')
@@ -184,8 +199,11 @@ instance Eq (DeBruijn Type) where
             -> D env t1 == D env' t1' && D env t2 == D env' t2'
         (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s
             -> D env t1 == D env' t1' && D env t2 == D env' t2'
-        (FunTy _ w1 t1 t2, FunTy _ w1' t1' t2')
-            -> D env w1 == D env w1' && D env t1 == D env' t1' && D env t2 == D env' t2'
+        (FunTy v1 w1 t1 t2, FunTy v1' w1' t1' t2')
+            -> v1 == v1' &&
+               D env w1 == D env w1' &&
+               D env t1 == D env' t1' &&
+               D env t2 == D env' t2'
         (TyConApp tc tys, TyConApp tc' tys')
             -> tc == tc' && D env tys == D env' tys'
         (LitTy l, LitTy l')
@@ -205,17 +223,19 @@ emptyT :: TypeMapX a
 emptyT = TM { tm_var  = emptyTM
             , tm_app  = emptyTM
             , tm_tycon  = emptyDNameEnv
+            , tm_funty  = emptyTM
             , tm_forall = emptyTM
             , tm_tylit  = emptyTyLitMap
             , tm_coerce = Nothing }
 
 mapT :: (a->b) -> TypeMapX a -> TypeMapX b
 mapT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon
-           , tm_forall = tforall, tm_tylit = tlit
+           , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit
            , tm_coerce = tcoerce })
   = TM { tm_var    = mapTM f tvar
        , tm_app    = mapTM (mapTM f) tapp
        , tm_tycon  = mapTM f ttycon
+       , tm_funty  = mapTM (mapTM (mapTM f)) tfunty
        , tm_forall = mapTM (mapTM f) tforall
        , tm_tylit  = mapTM f tlit
        , tm_coerce = fmap f tcoerce }
@@ -233,6 +253,11 @@ lkT (D env ty) m = go ty m
     go (LitTy l)                   = tm_tylit  >.> lkTyLit l
     go (ForAllTy (Bndr tv _) ty)   = tm_forall >.> lkG (D (extendCME env tv) ty)
                                                >=> lkBndr env tv
+    go (FunTy InvisArg _ arg res)
+      | Just res_rep <- getRuntimeRep_maybe res
+                                   = tm_funty >.> lkG (D env arg)
+                                              >=> lkG (D env res_rep)
+                                              >=> lkG (D env res)
     go ty@(FunTy {})               = pprPanic "lkT FunTy" (ppr ty)
     go (CastTy t _)                = go t
     go (CoercionTy {})             = tm_coerce
@@ -245,6 +270,10 @@ xtT (D env (TyVarTy v))       f m = m { tm_var    = tm_var m |> xtVar env v f }
 xtT (D env (AppTy t1 t2))     f m = m { tm_app    = tm_app m |> xtG (D env t1)
                                                             |>> xtG (D env t2) f }
 xtT (D _   (TyConApp tc []))  f m = m { tm_tycon  = tm_tycon m |> xtDNamed tc f }
+xtT (D env (FunTy InvisArg _ t1 t2)) f m = m { tm_funty = tm_funty m |> xtG (D env t1)
+                                                                    |>> xtG (D env t2_rep)
+                                                                    |>> xtG (D env t2) f }
+  where t2_rep = expectJust "xtT FunTy InvisArg" (getRuntimeRep_maybe t2)
 xtT (D _   (LitTy l))         f m = m { tm_tylit  = tm_tylit m |> xtTyLit l f }
 xtT (D env (CastTy t _))      f m = xtT (D env t) f m
 xtT (D _   (CoercionTy {}))   f m = m { tm_coerce = tm_coerce m |> f }
@@ -258,10 +287,23 @@ fdT :: (a -> b -> b) -> TypeMapX a -> b -> b
 fdT k m = foldTM k (tm_var m)
         . foldTM (foldTM k) (tm_app m)
         . foldTM k (tm_tycon m)
+        . foldTM (foldTM (foldTM k)) (tm_funty m)
         . foldTM (foldTM k) (tm_forall m)
         . foldTyLit k (tm_tylit m)
         . foldMaybe k (tm_coerce m)
 
+filterT :: (a -> Bool) -> TypeMapX a -> TypeMapX a
+filterT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon
+              , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit
+              , tm_coerce = tcoerce })
+  = TM { tm_var    = filterTM f tvar
+       , tm_app    = mapTM (filterTM f) tapp
+       , tm_tycon  = filterTM f ttycon
+       , tm_funty  = mapTM (mapTM (filterTM f)) tfunty
+       , tm_forall = mapTM (filterTM f) tforall
+       , tm_tylit  = filterTM f tlit
+       , tm_coerce = filterMaybe f tcoerce }
+
 ------------------------
 data TyLitMap a = TLM { tlm_number :: Map.Map Integer a
                       , tlm_string :: UniqFM  FastString a
@@ -274,6 +316,7 @@ instance TrieMap TyLitMap where
    alterTM  = xtTyLit
    foldTM   = foldTyLit
    mapTM    = mapTyLit
+   filterTM = filterTyLit
 
 emptyTyLitMap :: TyLitMap a
 emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM }
@@ -298,6 +341,10 @@ foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b
 foldTyLit l m = flip (foldUFM l) (tlm_string m)
               . flip (Map.foldr l)   (tlm_number m)
 
+filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a
+filterTyLit f (TLM { tlm_number = tn, tlm_string = ts })
+  = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts }
+
 -------------------------------------------------
 -- | @TypeMap a@ is a map from 'Type' to @a@.  If you are a client, this
 -- is the type you want. The keys in this map may have different kinds.
@@ -321,6 +368,7 @@ instance TrieMap TypeMap where
     alterTM k f m = xtTT (deBruijnize k) f m
     foldTM k (TypeMap m) = foldTM (foldTM k) m
     mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m)
+    filterTM f (TypeMap m) = TypeMap (mapTM (filterTM f) m)
 
 foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b
 foldTypeMap k z m = foldTM k m z
@@ -361,6 +409,7 @@ instance TrieMap LooseTypeMap where
   alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m)
   foldTM f (LooseTypeMap m) = foldTM f m
   mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m)
+  filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m)
 
 {-
 ************************************************************************
@@ -435,6 +484,7 @@ instance TrieMap BndrMap where
    alterTM  = xtBndr emptyCME
    foldTM   = fdBndrMap
    mapTM    = mapBndrMap
+   filterTM = ftBndrMap
 
 mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b
 mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm)
@@ -456,6 +506,8 @@ xtBndr :: forall a . CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a
 xtBndr env v xt (BndrMap tymap)  =
   BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt))
 
+ftBndrMap :: (a -> Bool) -> BndrMap a -> BndrMap a
+ftBndrMap f (BndrMap tm) = BndrMap (mapTM (filterTM f) tm)
 
 --------- Variable occurrence -------------
 data VarMap a = VM { vm_bvar   :: BoundVarMap a  -- Bound variable
@@ -468,6 +520,7 @@ instance TrieMap VarMap where
    alterTM  = xtVar emptyCME
    foldTM   = fdVar
    mapTM    = mapVar
+   filterTM = ftVar
 
 mapVar :: (a->b) -> VarMap a -> VarMap b
 mapVar f (VM { vm_bvar = bv, vm_fvar = fv })
@@ -493,6 +546,10 @@ lkDFreeVar var env = lookupDVarEnv env var
 xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a
 xtDFreeVar v f m = alterDVarEnv f m v
 
+ftVar :: (a -> Bool) -> VarMap a -> VarMap a
+ftVar f (VM { vm_bvar = bv, vm_fvar = fv })
+  = VM { vm_bvar = filterTM f bv, vm_fvar = filterTM f fv }
+
 -------------------------------------------------
 lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a
 lkDNamed n env = lookupDNameEnv env (getName n)
diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs
index dadb82c5f5463fc9849b04ee1390607c12cde70b..8277b0637809a1c28112c0ba2525597f6d85268c 100644
--- a/compiler/GHC/Core/TyCo/FVs.hs
+++ b/compiler/GHC/Core/TyCo/FVs.hs
@@ -26,7 +26,8 @@ module GHC.Core.TyCo.FVs
         injectiveVarsOfType, injectiveVarsOfTypes,
         invisibleVarsOfType, invisibleVarsOfTypes,
 
-        -- No Free vars
+        -- Any and No Free vars
+        anyFreeVarsOfType, anyFreeVarsOfTypes, anyFreeVarsOfCo,
         noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo,
 
         -- * Well-scoped free variables
@@ -47,7 +48,7 @@ import GHC.Prelude
 
 import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes)
 
-import Data.Monoid as DM ( Endo(..), All(..) )
+import Data.Monoid as DM ( Endo(..), Any(..) )
 import GHC.Core.TyCo.Rep
 import GHC.Core.TyCon
 import GHC.Types.Var
@@ -855,32 +856,43 @@ invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType
 
 {- *********************************************************************
 *                                                                      *
-                 No free vars
+                 Any free vars
 *                                                                      *
 ********************************************************************* -}
 
-nfvFolder :: TyCoFolder TyCoVarSet DM.All
-nfvFolder = TyCoFolder { tcf_view = noView
-                       , tcf_tyvar = do_tcv, tcf_covar = do_tcv
-                       , tcf_hole = do_hole, tcf_tycobinder = do_bndr }
+{-# INLINE afvFolder #-}   -- so that specialization to (const True) works
+afvFolder :: (TyCoVar -> Bool) -> TyCoFolder TyCoVarSet DM.Any
+afvFolder check_fv = TyCoFolder { tcf_view = noView
+                                , tcf_tyvar = do_tcv, tcf_covar = do_tcv
+                                , tcf_hole = do_hole, tcf_tycobinder = do_bndr }
   where
-    do_tcv is tv = All (tv `elemVarSet` is)
-    do_hole _ _  = All True    -- I'm unsure; probably never happens
+    do_tcv is tv = Any (not (tv `elemVarSet` is) && check_fv tv)
+    do_hole _ _  = Any False    -- I'm unsure; probably never happens
     do_bndr is tv _ = is `extendVarSet` tv
 
-nfv_ty  :: Type       -> DM.All
-nfv_tys :: [Type]     -> DM.All
-nfv_co  :: Coercion   -> DM.All
-(nfv_ty, nfv_tys, nfv_co, _) = foldTyCo nfvFolder emptyVarSet
+anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool
+anyFreeVarsOfType check_fv ty = DM.getAny (f ty)
+  where (f, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet
+
+anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool
+anyFreeVarsOfTypes check_fv tys = DM.getAny (f tys)
+  where (_, f, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet
+
+anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool
+anyFreeVarsOfCo check_fv co = DM.getAny (f co)
+  where (_, _, f, _) = foldTyCo (afvFolder check_fv) emptyVarSet
 
 noFreeVarsOfType :: Type -> Bool
-noFreeVarsOfType ty = DM.getAll (nfv_ty ty)
+noFreeVarsOfType ty = not $ DM.getAny (f ty)
+  where (f, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet
 
 noFreeVarsOfTypes :: [Type] -> Bool
-noFreeVarsOfTypes tys = DM.getAll (nfv_tys tys)
+noFreeVarsOfTypes tys = not $ DM.getAny (f tys)
+  where (_, f, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet
 
 noFreeVarsOfCo :: Coercion -> Bool
-noFreeVarsOfCo co = getAll (nfv_co co)
+noFreeVarsOfCo co = not $ DM.getAny (f co)
+  where (_, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet
 
 
 {- *********************************************************************
@@ -983,4 +995,3 @@ tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList
 -- | Get the free vars of types in scoped order
 tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]
 tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList
-
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index 1e8fcda0ca0303336395a665fca8f562e1f88b78..0be6824b9da9c3578b2e7bbfa112c922e0da2639 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -37,7 +37,7 @@ module GHC.Core.TyCo.Rep (
         -- * Coercions
         Coercion(..),
         UnivCoProvenance(..),
-        CoercionHole(..), BlockSubstFlag(..), coHoleCoVar, setCoHoleCoVar,
+        CoercionHole(..), coHoleCoVar, setCoHoleCoVar,
         CoercionN, CoercionR, CoercionP, KindCoercion,
         MCoercion(..), MCoercionR, MCoercionN,
 
@@ -93,7 +93,7 @@ import GHC.Core.Coercion.Axiom
 import GHC.Builtin.Names ( liftedTypeKindTyConKey, manyDataConKey )
 import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, manyDataConTy )
 import GHC.Types.Basic ( LeftOrRight(..), pickLR )
-import GHC.Types.Unique ( hasKey )
+import GHC.Types.Unique ( hasKey, Uniquable(..) )
 import GHC.Utils.Outputable
 import GHC.Data.FastString
 import GHC.Utils.Misc
@@ -1588,15 +1588,9 @@ data CoercionHole
   = CoercionHole { ch_co_var  :: CoVar
                        -- See Note [CoercionHoles and coercion free variables]
 
-                 , ch_blocker :: BlockSubstFlag  -- should this hole block substitution?
-                                                 -- See (2a) in TcCanonical
-                                                 -- Note [Equalities with incompatible kinds]
                  , ch_ref     :: IORef (Maybe Coercion)
                  }
 
-data BlockSubstFlag = YesBlockSubst
-                    | NoBlockSubst
-
 coHoleCoVar :: CoercionHole -> CoVar
 coHoleCoVar = ch_co_var
 
@@ -1612,9 +1606,8 @@ instance Data.Data CoercionHole where
 instance Outputable CoercionHole where
   ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv)
 
-instance Outputable BlockSubstFlag where
-  ppr YesBlockSubst = text "YesBlockSubst"
-  ppr NoBlockSubst  = text "NoBlockSubst"
+instance Uniquable CoercionHole where
+  getUnique (CoercionHole { ch_co_var = cv }) = getUnique cv
 
 {- Note [Phantom coercions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index b82dd5cb2612faad251ca057aca21a928b930ef7..198b66959bb33fbcb9ce2a6a6f8431eeff7104ad 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -56,7 +56,7 @@ module GHC.Core.TyCon(
         mustBeSaturated,
         isPromotedDataCon, isPromotedDataCon_maybe,
         isKindTyCon, isLiftedTypeKindTyConName,
-        isTauTyCon, isFamFreeTyCon,
+        isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon,
 
         isDataTyCon, isProductTyCon, isDataProductTyCon_maybe,
         isDataSumTyCon_maybe,
@@ -817,10 +817,15 @@ data TyCon
         synIsTau     :: Bool,   -- True <=> the RHS of this synonym does not
                                  --          have any foralls, after expanding any
                                  --          nested synonyms
-        synIsFamFree  :: Bool    -- True <=> the RHS of this synonym does not mention
+        synIsFamFree  :: Bool,   -- True <=> the RHS of this synonym does not mention
                                  --          any type synonym families (data families
                                  --          are fine), again after expanding any
                                  --          nested synonyms
+        synIsForgetful :: Bool   -- True <=  at least one argument is not mentioned
+                                 --          in the RHS (or is mentioned only under
+                                 --          forgetful synonyms)
+                                 -- Test is conservative, so True does not guarantee
+                                 -- forgetfulness.
     }
 
   -- | Represents families (both type and data)
@@ -1779,20 +1784,21 @@ mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm
 
 -- | Create a type synonym 'TyCon'
 mkSynonymTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind
-               -> [Role] -> Type -> Bool -> Bool -> TyCon
-mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free
+               -> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon
+mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful
   = SynonymTyCon {
-        tyConName    = name,
-        tyConUnique  = nameUnique name,
-        tyConBinders = binders,
-        tyConResKind = res_kind,
-        tyConKind    = mkTyConKind binders res_kind,
-        tyConArity   = length binders,
-        tyConTyVars  = binderVars binders,
-        tcRoles      = roles,
-        synTcRhs     = rhs,
-        synIsTau     = is_tau,
-        synIsFamFree = is_fam_free
+        tyConName      = name,
+        tyConUnique    = nameUnique name,
+        tyConBinders   = binders,
+        tyConResKind   = res_kind,
+        tyConKind      = mkTyConKind binders res_kind,
+        tyConArity     = length binders,
+        tyConTyVars    = binderVars binders,
+        tcRoles        = roles,
+        synTcRhs       = rhs,
+        synIsTau       = is_tau,
+        synIsFamFree   = is_fam_free,
+        synIsForgetful = is_forgetful
     }
 
 -- | Create a type family 'TyCon'
@@ -2046,11 +2052,22 @@ isTauTyCon :: TyCon -> Bool
 isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau
 isTauTyCon _                                    = True
 
+-- | Is this tycon neither a type family nor a synonym that expands
+-- to a type family?
 isFamFreeTyCon :: TyCon -> Bool
 isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free
 isFamFreeTyCon (FamilyTyCon { famTcFlav = flav })         = isDataFamFlav flav
 isFamFreeTyCon _                                          = True
 
+-- | Is this a forgetful type synonym? If this is a type synonym whose
+-- RHS does not mention one (or more) of its bound variables, returns
+-- True. Thus, False means that all bound variables appear on the RHS;
+-- True may not mean anything, as the test to set this flag is
+-- conservative.
+isForgetfulSynTyCon :: TyCon -> Bool
+isForgetfulSynTyCon (SynonymTyCon { synIsForgetful = forget }) = forget
+isForgetfulSynTyCon _                                          = False
+
 -- As for newtypes, it is in some contexts important to distinguish between
 -- closed synonyms and synonym families, as synonym families have no unique
 -- right hand side to which a synonym family application can expand.
@@ -2118,7 +2135,7 @@ isClosedSynFamilyTyConWithAxiom_maybe
   (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb
 isClosedSynFamilyTyConWithAxiom_maybe _               = Nothing
 
--- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an
+-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an
 -- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is
 -- injective), or 'NotInjective' otherwise.
 tyConInjectivityInfo :: TyCon -> Injectivity
diff --git a/compiler/GHC/Core/TyCon/Env.hs b/compiler/GHC/Core/TyCon/Env.hs
index 76edb829fdd17cc795124bcde893a491fbedc8d2..d5947a2fdabcc3382c78c18ee78623f6126d908d 100644
--- a/compiler/GHC/Core/TyCon/Env.hs
+++ b/compiler/GHC/Core/TyCon/Env.hs
@@ -26,11 +26,11 @@ module GHC.Core.TyCon.Env (
 
         DTyConEnv,
 
-        emptyDTyConEnv,
+        emptyDTyConEnv, isEmptyDTyConEnv,
         lookupDTyConEnv,
         delFromDTyConEnv, filterDTyConEnv,
-        mapDTyConEnv,
-        adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv,
+        mapDTyConEnv, mapMaybeDTyConEnv,
+        adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv, foldDTyConEnv
     ) where
 
 #include "HsVersions.h"
@@ -116,6 +116,9 @@ type DTyConEnv a = UniqDFM TyCon a
 emptyDTyConEnv :: DTyConEnv a
 emptyDTyConEnv = emptyUDFM
 
+isEmptyDTyConEnv :: DTyConEnv a -> Bool
+isEmptyDTyConEnv = isNullUDFM
+
 lookupDTyConEnv :: DTyConEnv a -> TyCon -> Maybe a
 lookupDTyConEnv = lookupUDFM
 
@@ -128,6 +131,9 @@ filterDTyConEnv = filterUDFM
 mapDTyConEnv :: (a -> b) -> DTyConEnv a -> DTyConEnv b
 mapDTyConEnv = mapUDFM
 
+mapMaybeDTyConEnv :: (a -> Maybe b) -> DTyConEnv a -> DTyConEnv b
+mapMaybeDTyConEnv = mapMaybeUDFM
+
 adjustDTyConEnv :: (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a
 adjustDTyConEnv = adjustUDFM
 
@@ -136,3 +142,6 @@ alterDTyConEnv = alterUDFM
 
 extendDTyConEnv :: DTyConEnv a -> TyCon -> a -> DTyConEnv a
 extendDTyConEnv = addToUDFM
+
+foldDTyConEnv :: (elt -> a -> a) -> a -> DTyConEnv elt -> a
+foldDTyConEnv = foldUDFM
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index b983671d116bf92711b19fc4c901508dd4c8f0f0..3164e2626beb729879354a776a11a5da0cd0bf4c 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -29,7 +29,7 @@ module GHC.Core.Type (
         mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys,
         splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe,
 
-        mkVisFunTy, mkInvisFunTy,
+        mkFunTy, mkVisFunTy, mkInvisFunTy,
         mkVisFunTys,
         mkVisFunTyMany, mkInvisFunTyMany,
         mkVisFunTysMany, mkInvisFunTysMany,
@@ -155,6 +155,7 @@ module GHC.Core.Type (
         coVarsOfType,
         coVarsOfTypes,
 
+        anyFreeVarsOfType, anyFreeVarsOfTypes,
         noFreeVarsOfType,
         splitVisVarsOfType, splitVisVarsOfTypes,
         expandTypeSynonyms,
@@ -1343,11 +1344,19 @@ splitTyConApp_maybe = repSplitTyConApp_maybe . coreFullView
 -- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your
 -- type before using this function.
 --
+-- This does *not* split types headed with (=>), as that's not a TyCon in the
+-- type-checker.
+--
 -- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'.
 tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
 -- Defined here to avoid module loops between Unify and TcType.
 tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'
-tcSplitTyConApp_maybe ty                         = repSplitTyConApp_maybe ty
+tcSplitTyConApp_maybe (TyConApp tc tys)          = Just (tc, tys)
+tcSplitTyConApp_maybe (FunTy VisArg w arg res)
+  | Just arg_rep <- getRuntimeRep_maybe arg
+  , Just res_rep <- getRuntimeRep_maybe res
+  = Just (funTyCon, [w, arg_rep, res_rep, arg, res])
+tcSplitTyConApp_maybe _ = Nothing
 
 -------------------
 repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
@@ -1358,7 +1367,7 @@ repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
 -- have enough info to extract the runtime-rep arguments that
 -- the funTyCon requires.  This will usually be true;
 -- but may be temporarily false during canonicalization:
---     see Note [FunTy and decomposing tycon applications] in "GHC.Tc.Solver.Canonical"
+--     see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical
 --
 repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 repSplitTyConApp_maybe (FunTy _ w arg res)
@@ -1966,13 +1975,17 @@ isCoVarType ty
 
 buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind   -- ^ /result/ kind
               -> [Role] -> KnotTied Type -> TyCon
--- This function is here beucase here is where we have
+-- This function is here because here is where we have
 --   isFamFree and isTauTy
 buildSynTyCon name binders res_kind roles rhs
-  = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free
+  = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful
   where
-    is_tau      = isTauTy rhs
-    is_fam_free = isFamFreeTy rhs
+    is_tau       = isTauTy rhs
+    is_fam_free  = isFamFreeTy rhs
+    is_forgetful = any (not . (`elemVarSet` tyCoVarsOfType rhs) . binderVar) binders ||
+                   uniqSetAny isForgetfulSynTyCon (tyConsOfType rhs)
+         -- NB: This is allowed to be conservative, returning True more often
+         -- than it should. See comments on GHC.Core.TyCon.isForgetfulSynTyCon
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs
index c99913d3bec164930207690976d15dbd06567a21..a8f75535abb8d40b30480373449b20884b8505f9 100644
--- a/compiler/GHC/Core/Unify.hs
+++ b/compiler/GHC/Core/Unify.hs
@@ -24,7 +24,7 @@ module GHC.Core.Unify (
         liftCoMatch,
 
         -- The core flattening algorithm
-        flattenTys
+        flattenTys, flattenTysX
    ) where
 
 #include "HsVersions.h"
@@ -363,12 +363,6 @@ types are apart. This has practical consequences for the ability for closed
 type family applications to reduce. See test case
 indexed-types/should_compile/Overlap14.
 
-Note [Unification with skolems]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we discover that two types unify if and only if a skolem variable is
-substituted, we can't properly unify the types. But, that skolem variable
-may later be instantiated with a unifyable type. So, we return maybeApart
-in these cases.
 -}
 
 -- | Simple unification of two types; all type variables are bindable
@@ -699,8 +693,9 @@ unifier It does /not/ work up to ~.
 The algorithm implemented here is rather delicate, and we depend on it
 to uphold certain properties. This is a summary of these required
 properties. Any reference to "flattening" refers to the flattening
-algorithm in GHC.Core.FamInstEnv (See Note [Flattening] in GHC.Core.Unify), not
-the flattening algorithm in the solver.
+algorithm in GHC.Core.Unify (See
+Note [Flattening type-family applications when matching instances] in GHC.Core.Unify),
+not the flattening algorithm in the solver.
 
 Notation:
  θ,φ    substitutions
@@ -983,9 +978,11 @@ unify_ty env ty1 (TyVarTy tv2) kco
   = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco)
 
 unify_ty env ty1 ty2 _kco
+ -- NB: This keeps Constraint and Type distinct, as it should for use in the
+ -- type-checker.
   | Just (tc1, tys1) <- mb_tc_app1
   , Just (tc2, tys2) <- mb_tc_app2
-  , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2)
+  , tc1 == tc2
   = if isInjectiveTyCon tc1 Nominal
     then unify_tys env tys1 tys2
     else do { let inj | isTypeFamilyTyCon tc1
@@ -1034,6 +1031,16 @@ unify_ty env ty1 (AppTy ty2a ty2b) _kco
   | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1
   = unify_ty_app env ty1a [ty1b] ty2a [ty2b]
 
+  -- tcSplitTyConApp won't split a (=>), so we handle this separately.
+unify_ty env (FunTy InvisArg _w1 arg1 res1) (FunTy InvisArg _w2 arg2 res2) _kco
+   -- Look at result representations, but arg representations would be redundant
+   -- as anything that can appear to the left of => is lifted.
+   -- And anything that can appear to the left of => is unrestricted, so skip the
+   -- multiplicities.
+  | Just res_rep1 <- getRuntimeRep_maybe res1
+  , Just res_rep2 <- getRuntimeRep_maybe res2
+  = unify_tys env [res_rep1, arg1, res1] [res_rep2, arg2, res2]
+
 unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()
 
 unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco
@@ -1163,12 +1170,12 @@ uUnrefined env tv1' ty2 ty2' kco
              -- How could this happen? If we're only matching and if
              -- we're comparing forall-bound variables.
 
-           _ -> maybeApart -- See Note [Unification with skolems]
+           _ -> surelyApart
   }}}}
 
 uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable
   = case tvBindFlag env tv1' of
-      Skolem -> maybeApart  -- See Note [Unification with skolems]
+      Skolem -> surelyApart
       BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco)
 
 bindTv :: UMEnv -> OutTyVar -> Type -> UM ()
@@ -1211,6 +1218,9 @@ data BindFlag
 
   | Skolem      -- This type variable is a skolem constant
                 -- Don't bind it; it only matches itself
+                -- These variables are SurelyApart from other types
+                -- See Note [Binding when looking up instances] in GHC.Core.InstEnv
+                -- for why it must be SurelyApart.
   deriving Eq
 
 {-
@@ -1616,8 +1626,8 @@ pushRefl co =
 *                                                                      *
 ************************************************************************
 
-Note [Flattening]
-~~~~~~~~~~~~~~~~~
+Note [Flattening type-family applications when matching instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 As described in "Closed type families with overlapping equations"
 http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf
 we need to flatten core types before unifying them, when checking for "surely-apart"
@@ -1646,6 +1656,15 @@ can see that (F x x) can reduce to Double. So, it had better be the
 case that (F blah blah) can reduce to Double, no matter what (blah)
 is!  Flattening as done below ensures this.
 
+We also use this flattening operation to check for class instances.
+If we have
+  instance C (Maybe b)
+  instance {-# OVERLAPPING #-} C (Maybe Bool)
+  [W] C (Maybe (F a))
+we want to know that the second instance might match later. So we
+flatten the (F a) in the target before trying to unify with instances.
+(This is done in GHC.Core.InstEnv.lookupInstEnv'.)
+
 The algorithm works by building up a TypeMap TyVar, mapping
 type family applications to fresh variables. This mapping must
 be threaded through all the function calls, as any entry in
@@ -1758,11 +1777,11 @@ flattenTys is defined here because of module dependencies.
 -}
 
 data FlattenEnv
-  = FlattenEnv { fe_type_map :: TypeMap TyVar
+  = FlattenEnv { fe_type_map :: TypeMap (TyVar, TyCon, [Type])
                  -- domain: exactly-saturated type family applications
-                 -- range: fresh variables
+                 -- range: (fresh variable, type family tycon, args)
                , fe_in_scope :: InScopeSet }
-                 -- See Note [Flattening]
+                 -- See Note [Flattening type-family applications when matching instances]
 
 emptyFlattenEnv :: InScopeSet -> FlattenEnv
 emptyFlattenEnv in_scope
@@ -1773,13 +1792,29 @@ updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv
 updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }
 
 flattenTys :: InScopeSet -> [Type] -> [Type]
--- See Note [Flattening]
--- NB: the returned types may mention fresh type variables,
---     arising from the flattening.  We don't return the
---     mapping from those fresh vars to the ty-fam
---     applications they stand for (we could, but no need)
-flattenTys in_scope tys
-  = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys
+-- See Note [Flattening type-family applications when matching instances]
+flattenTys in_scope tys = fst (flattenTysX in_scope tys)
+
+flattenTysX :: InScopeSet -> [Type] -> ([Type], TyVarEnv (TyCon, [Type]))
+-- See Note [Flattening type-family applications when matching instances]
+-- NB: the returned types mention the fresh type variables
+--     in the domain of the returned env, whose range includes
+--     the original type family applications. Building a substitution
+--     from this information and applying it would yield the original
+--     types -- almost. The problem is that the original type might
+--     have something like (forall b. F a b); the returned environment
+--     can't really sensibly refer to that b. So it may include a locally-
+--     bound tyvar in its range. Currently, the only usage of this env't
+--     checks whether there are any meta-variables in it
+--     (in GHC.Tc.Solver.Monad.mightMatchLater), so this is all OK.
+flattenTysX in_scope tys
+  = let (env, result) = coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys in
+    (result, build_env (fe_type_map env))
+  where
+    build_env :: TypeMap (TyVar, TyCon, [Type]) -> TyVarEnv (TyCon, [Type])
+    build_env env_in
+      = foldTM (\(tv, tc, tys) env_out -> extendVarEnv env_out tv (tc, tys))
+               env_in emptyVarEnv
 
 coreFlattenTys :: TvSubstEnv -> FlattenEnv
                -> [Type] -> (FlattenEnv, [Type])
@@ -1841,7 +1876,7 @@ coreFlattenCo subst env co
     (env1, kind') = coreFlattenTy subst env (coercionType co)
     covar         = mkFlattenFreshCoVar (fe_in_scope env1) kind'
     -- Add the covar to the FlattenEnv's in-scope set.
-    -- See Note [Flattening], wrinkle 2A.
+    -- See Note [Flattening type-family applications when matching instances], wrinkle 2A.
     env2          = updateInScopeSet env1 (flip extendInScopeSet covar)
 
 coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv
@@ -1849,7 +1884,7 @@ coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv
 coreFlattenVarBndr subst env tv
   = (env2, subst', tv')
   where
-    -- See Note [Flattening], wrinkle 2B.
+    -- See Note [Flattening type-family applications when matching instances], wrinkle 2B.
     kind          = varType tv
     (env1, kind') = coreFlattenTy subst env kind
     tv'           = uniqAway (fe_in_scope env1) (setVarType tv kind')
@@ -1862,26 +1897,30 @@ coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv
                     -> (FlattenEnv, Type)
 coreFlattenTyFamApp tv_subst env fam_tc fam_args
   = case lookupTypeMap type_map fam_ty of
-      Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args')
-      Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc
-                     tv         = uniqAway in_scope $
-                                  mkTyVar tyvar_name (typeKind fam_ty)
-
-                     ty'   = mkAppTys (mkTyVarTy tv) leftover_args'
-                     env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv
-                                  , fe_in_scope = extendInScopeSet in_scope tv }
-                 in (env'', ty')
+      Just (tv, _, _) -> (env', mkAppTys (mkTyVarTy tv) leftover_args')
+      Nothing ->
+        let tyvar_name = mkFlattenFreshTyName fam_tc
+            tv         = uniqAway in_scope $
+                         mkTyVar tyvar_name (typeKind fam_ty)
+
+            ty'   = mkAppTys (mkTyVarTy tv) leftover_args'
+            env'' = env' { fe_type_map = extendTypeMap type_map fam_ty
+                                                       (tv, fam_tc, sat_fam_args)
+                         , fe_in_scope = extendInScopeSet in_scope tv }
+        in (env'', ty')
   where
     arity = tyConArity fam_tc
     tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv
     (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args )
                                     splitAt arity fam_args
     -- Apply the substitution before looking up an application in the
-    -- environment. See Note [Flattening], wrinkle 1.
+    -- environment. See Note [Flattening type-family applications when matching instances],
+    -- wrinkle 1.
     -- NB: substTys short-cuts the common case when the substitution is empty.
     sat_fam_args' = substTys tcv_subst sat_fam_args
     (env', leftover_args') = coreFlattenTys tv_subst env leftover_args
-    -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening],
+    -- `fam_tc` may be over-applied to `fam_args` (see
+    -- Note [Flattening type-family applications when matching instances]
     -- wrinkle 3), so we split it into the arguments needed to saturate it
     -- (sat_fam_args') and the rest (leftover_args')
     fam_ty = mkTyConApp fam_tc sat_fam_args'
diff --git a/compiler/GHC/Data/Bag.hs b/compiler/GHC/Data/Bag.hs
index 75e7927a6b2acd40e6a941ff73254d23f8793169..e314309efcd2237eb715c7f3a9f3d0a06901f868 100644
--- a/compiler/GHC/Data/Bag.hs
+++ b/compiler/GHC/Data/Bag.hs
@@ -17,7 +17,7 @@ module GHC.Data.Bag (
         filterBag, partitionBag, partitionBagWith,
         concatBag, catBagMaybes, foldBag,
         isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag,
-        listToBag, bagToList, mapAccumBagL,
+        listToBag, nonEmptyToBag, bagToList, mapAccumBagL,
         concatMapBag, concatMapBagPair, mapMaybeBag,
         mapBagM, mapBagM_,
         flatMapBagM, flatMapBagPairM,
@@ -35,6 +35,7 @@ import Control.Monad
 import Data.Data
 import Data.Maybe( mapMaybe )
 import Data.List ( partition, mapAccumL )
+import Data.List.NonEmpty ( NonEmpty(..) )
 import qualified Data.Foldable as Foldable
 
 infixr 3 `consBag`
@@ -299,6 +300,10 @@ listToBag [] = EmptyBag
 listToBag [x] = UnitBag x
 listToBag vs = ListBag vs
 
+nonEmptyToBag :: NonEmpty a -> Bag a
+nonEmptyToBag (x :| []) = UnitBag x
+nonEmptyToBag (x :| xs) = ListBag (x : xs)
+
 bagToList :: Bag a -> [a]
 bagToList b = foldr (:) [] b
 
diff --git a/compiler/GHC/Data/Maybe.hs b/compiler/GHC/Data/Maybe.hs
index 230468a20e385c36f831719bc69f97315e0190f4..ac9c687b628c097aecbbf8166918c07dbae1de85 100644
--- a/compiler/GHC/Data/Maybe.hs
+++ b/compiler/GHC/Data/Maybe.hs
@@ -16,7 +16,7 @@ module GHC.Data.Maybe (
         failME, isSuccess,
 
         orElse,
-        firstJust, firstJusts,
+        firstJust, firstJusts, firstJustsM,
         whenIsJust,
         expectJust,
         rightToMaybe,
@@ -31,6 +31,7 @@ import Control.Monad
 import Control.Monad.Trans.Maybe
 import Control.Exception (catch, SomeException(..))
 import Data.Maybe
+import Data.Foldable ( foldlM )
 import GHC.Utils.Misc (HasCallStack)
 
 infixr 4 `orElse`
@@ -51,6 +52,15 @@ firstJust a b = firstJusts [a, b]
 firstJusts :: [Maybe a] -> Maybe a
 firstJusts = msum
 
+-- | Takes computations returnings @Maybes@; tries each one in order.
+-- The first one to return a @Just@ wins. Returns @Nothing@ if all computations
+-- return @Nothing@.
+firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)
+firstJustsM = foldlM go Nothing where
+  go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)
+  go Nothing         action  = action
+  go result@(Just _) _action = return result
+
 expectJust :: HasCallStack => String -> Maybe a -> a
 {-# INLINE expectJust #-}
 expectJust _   (Just x) = x
diff --git a/compiler/GHC/Data/TrieMap.hs b/compiler/GHC/Data/TrieMap.hs
index 52a5b4ac78f4466f6fd6b4ada2997ab629add254..54128d28f8c95e4d47b51df9cfed449e7c49b4ec 100644
--- a/compiler/GHC/Data/TrieMap.hs
+++ b/compiler/GHC/Data/TrieMap.hs
@@ -16,11 +16,11 @@ module GHC.Data.TrieMap(
    -- * Maps over 'Literal's
    LiteralMap,
    -- * 'TrieMap' class
-   TrieMap(..), insertTM, deleteTM,
+   TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM,
 
    -- * Things helpful for adding additional Instances.
    (>.>), (|>), (|>>), XT,
-   foldMaybe,
+   foldMaybe, filterMaybe,
    -- * Map for leaf compression
    GenMap,
    lkG, xtG, mapG, fdG,
@@ -40,6 +40,8 @@ import GHC.Utils.Outputable
 import Control.Monad( (>=>) )
 import Data.Kind( Type )
 
+import qualified Data.Semigroup as S
+
 {-
 This module implements TrieMaps, which are finite mappings
 whose key is a structured value like a CoreExpr or Type.
@@ -70,6 +72,7 @@ class TrieMap m where
    lookupTM :: forall b. Key m -> m b -> Maybe b
    alterTM  :: forall b. Key m -> XT b -> m b -> m b
    mapTM    :: (a->b) -> m a -> m b
+   filterTM :: (a -> Bool) -> m a -> m a
 
    foldTM   :: (a -> b -> b) -> m a -> b -> b
       -- The unusual argument order here makes
@@ -82,6 +85,13 @@ insertTM k v m = alterTM k (\_ -> Just v) m
 deleteTM :: TrieMap m => Key m -> m a -> m a
 deleteTM k m = alterTM k (\_ -> Nothing) m
 
+foldMapTM :: (TrieMap m, Monoid r) => (a -> r) -> m a -> r
+foldMapTM f m = foldTM (\ x r -> f x S.<> r) m mempty
+
+-- This looks inefficient.
+isEmptyTM :: TrieMap m => m a -> Bool
+isEmptyTM m = foldTM (\ _ _ -> False) m True
+
 ----------------------
 -- Recall that
 --   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c
@@ -121,6 +131,7 @@ instance TrieMap IntMap.IntMap where
   alterTM = xtInt
   foldTM k m z = IntMap.foldr k z m
   mapTM f m = IntMap.map f m
+  filterTM f m = IntMap.filter f m
 
 xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a
 xtInt k f m = IntMap.alter f k m
@@ -132,6 +143,7 @@ instance Ord k => TrieMap (Map.Map k) where
   alterTM k f m = Map.alter f k m
   foldTM k m z = Map.foldr k z m
   mapTM f m = Map.map f m
+  filterTM f m = Map.filter f m
 
 
 {-
@@ -208,6 +220,7 @@ instance forall key. Uniquable key => TrieMap (UniqDFM key) where
   alterTM k f m = alterUDFM f m k
   foldTM k m z = foldUDFM k z m
   mapTM f m = mapUDFM f m
+  filterTM f m = filterUDFM f m
 
 {-
 ************************************************************************
@@ -229,6 +242,10 @@ instance TrieMap m => TrieMap (MaybeMap m) where
    alterTM  = xtMaybe alterTM
    foldTM   = fdMaybe
    mapTM    = mapMb
+   filterTM = ftMaybe
+
+instance TrieMap m => Foldable (MaybeMap m) where
+  foldMap = foldMapTM
 
 mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b
 mapMb f (MM { mm_nothing = mn, mm_just = mj })
@@ -248,6 +265,19 @@ fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b
 fdMaybe k m = foldMaybe k (mm_nothing m)
             . foldTM k (mm_just m)
 
+ftMaybe :: TrieMap m => (a -> Bool) -> MaybeMap m a -> MaybeMap m a
+ftMaybe f (MM { mm_nothing = mn, mm_just = mj })
+  = MM { mm_nothing = filterMaybe f mn, mm_just = filterTM f mj }
+
+foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b
+foldMaybe _ Nothing  b = b
+foldMaybe k (Just a) b = k a b
+
+filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a
+filterMaybe _ Nothing = Nothing
+filterMaybe f input@(Just x) | f x       = input
+                             | otherwise = Nothing
+
 {-
 ************************************************************************
 *                                                                      *
@@ -267,6 +297,10 @@ instance TrieMap m => TrieMap (ListMap m) where
    alterTM  = xtList alterTM
    foldTM   = fdList
    mapTM    = mapList
+   filterTM = ftList
+
+instance TrieMap m => Foldable (ListMap m) where
+  foldMap = foldMapTM
 
 instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where
   ppr m = text "List elts" <+> ppr (foldTM (:) m [])
@@ -290,9 +324,9 @@ fdList :: forall m a b. TrieMap m
 fdList k m = foldMaybe k          (lm_nil m)
            . foldTM    (fdList k) (lm_cons m)
 
-foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b
-foldMaybe _ Nothing  b = b
-foldMaybe k (Just a) b = k a b
+ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a
+ftList f (LM { lm_nil = mnil, lm_cons = mcons })
+  = LM { lm_nil = filterMaybe f mnil, lm_cons = mapTM (filterTM f) mcons }
 
 {-
 ************************************************************************
@@ -354,6 +388,10 @@ instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where
    alterTM  = xtG
    foldTM   = fdG
    mapTM    = mapG
+   filterTM = ftG
+
+instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where
+  foldMap = foldMapTM
 
 --We want to be able to specialize these functions when defining eg
 --tries over (GenMap CoreExpr) which requires INLINEABLE
@@ -403,3 +441,13 @@ fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b
 fdG _ EmptyMap = \z -> z
 fdG k (SingletonMap _ v) = \z -> k v z
 fdG k (MultiMap m) = foldTM k m
+
+{-# INLINEABLE ftG #-}
+ftG :: TrieMap m => (a -> Bool) -> GenMap m a -> GenMap m a
+ftG _ EmptyMap = EmptyMap
+ftG f input@(SingletonMap _ v)
+  | f v       = input
+  | otherwise = EmptyMap
+ftG f (MultiMap m) = MultiMap (filterTM f m)
+  -- we don't have enough information to reconstruct the key to make
+  -- a SingletonMap
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 25acaab3596ec693a1a64fabadf8a61ecc9af097..3d0908caa021e55492ead1652d1cf2042911b41a 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -263,7 +263,7 @@ data GeneralFlag
    | Opt_RPath
    | Opt_RelativeDynlibPaths
    | Opt_Hpc
-   | Opt_FlatCache
+   | Opt_FamAppCache
    | Opt_ExternalInterpreter
    | Opt_OptimalApplicativeDo
    | Opt_VersionMacros
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 7be2da383cf7edc51cdb4bf8d49fb6af31393b3a..024ac97c0597a873acc1af407335eaa6c4a4610c 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3413,7 +3413,7 @@ fFlagsDeps = [
   flagSpec "expose-internal-symbols"          Opt_ExposeInternalSymbols,
   flagSpec "external-dynamic-refs"            Opt_ExternalDynamicRefs,
   flagSpec "external-interpreter"             Opt_ExternalInterpreter,
-  flagSpec "flat-cache"                       Opt_FlatCache,
+  flagSpec "family-application-cache"         Opt_FamAppCache,
   flagSpec "float-in"                         Opt_FloatIn,
   flagSpec "force-recomp"                     Opt_ForceRecomp,
   flagSpec "ignore-optim-changes"             Opt_IgnoreOptimChanges,
@@ -3771,7 +3771,7 @@ defaultFlags settings
   = [ Opt_AutoLinkPackages,
       Opt_DiagnosticsShowCaret,
       Opt_EmbedManifest,
-      Opt_FlatCache,
+      Opt_FamAppCache,
       Opt_GenManifest,
       Opt_GhciHistory,
       Opt_GhciSandbox,
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index c8f45a307b09d90b804286182c16c09847577e24..f17018492c9c12d5e13c11315fa34ab312d6f316 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -298,12 +298,19 @@ initTcDsForSolver thing_inside
        ; hsc_env    <- getTopEnv
 
        ; let DsGblEnv { ds_mod = mod
-                      , ds_fam_inst_env = fam_inst_env } = gbl
+                      , ds_fam_inst_env = fam_inst_env
+                      , ds_gbl_rdr_env  = rdr_env }      = gbl
+       -- This is *the* use of ds_gbl_rdr_env:
+       -- Make sure the solver (used by the pattern-match overlap checker) has
+       -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it
+       -- knows how to reduce type families, and which newtypes it can unwrap.
+
 
              DsLclEnv { dsl_loc = loc }                  = lcl
 
        ; liftIO $ initTc hsc_env HsSrcFile False mod loc $
-         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
+         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env
+                                      , tcg_rdr_env      = rdr_env }) $
          thing_inside }
 
 mkDsEnvs :: UnitState -> HomeUnit -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
@@ -318,6 +325,7 @@ mkDsEnvs unit_state home_unit mod rdr_env type_env fam_inst_env msg_var cc_st_va
         real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
         gbl_env = DsGblEnv { ds_mod     = mod
                            , ds_fam_inst_env = fam_inst_env
+                           , ds_gbl_rdr_env  = rdr_env
                            , ds_if_env  = (if_genv, if_lenv)
                            , ds_unqual  = mkPrintUnqualified unit_state home_unit rdr_env
                            , ds_msgs    = msg_var
diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs
index 68da67d21eea756147baa249de81c338c7ad83dc..aeeeb0c53086b73dc9250d0728b0efccf53a612d 100644
--- a/compiler/GHC/HsToCore/Types.hs
+++ b/compiler/GHC/HsToCore/Types.hs
@@ -12,6 +12,7 @@ import GHC.Types.CostCentre.State
 import GHC.Types.Name.Env
 import GHC.Types.SrcLoc
 import GHC.Types.Var
+import GHC.Types.Name.Reader (GlobalRdrEnv)
 import GHC.Hs (LForeignDecl, HsExpr, GhcTc)
 import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches)
 import GHC.HsToCore.Pmc.Types (Nablas)
@@ -42,6 +43,9 @@ data DsGblEnv
   = DsGblEnv
   { ds_mod          :: Module             -- For SCC profiling
   , ds_fam_inst_env :: FamInstEnv         -- Like tcg_fam_inst_env
+  , ds_gbl_rdr_env  :: GlobalRdrEnv       -- needed *only* to know what newtype
+                                          -- constructors are in scope during
+                                          -- pattern-match satisfiability checking
   , ds_unqual  :: PrintUnqualified
   , ds_msgs    :: IORef Messages          -- Warning messages
   , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,
diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs
index 5a2b9b16fa1b37bf4055cb7bfa1fbca6799e224b..61a7824188ee9b3919669a180689222535f8d7f9 100644
--- a/compiler/GHC/Stg/CSE.hs
+++ b/compiler/GHC/Stg/CSE.hs
@@ -130,6 +130,8 @@ instance TrieMap StgArgMap where
     foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)
     mapTM f (SAM {sam_var = varm, sam_lit = litm}) =
         SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }
+    filterTM f (SAM {sam_var = varm, sam_lit = litm}) =
+        SAM { sam_var = filterTM f varm, sam_lit = filterTM f litm }
 
 newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }
 
@@ -141,6 +143,7 @@ instance TrieMap ConAppMap where
         m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }
     foldTM k = un_cam >.> foldTM (foldTM k)
     mapTM f  = un_cam >.> mapTM (mapTM f) >.> CAM
+    filterTM f = un_cam >.> mapTM (filterTM f) >.> CAM
 
 -----------------
 -- The CSE Env --
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 028d9b16a6926c495c8ea4119d89272b179f114d..c2c4c2c53b4bc13430e8ce376f92bc10abc11f52 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -210,8 +210,6 @@ report_unsolved type_errors expr_holes
        ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
 
        ; wanted <- zonkWC wanted   -- Zonk to reveal all information
-            -- If we are deferring we are going to need /all/ evidence around,
-            -- including the evidence produced by unflattening (zonkWC)
        ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs
              free_tvs = filterOut isCoVar $
                         tyCoVarsOfWCList wanted
@@ -619,7 +617,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
     -- also checks to make sure the constraint isn't BlockedCIS
     -- See TcCanonical Note [Equalities with incompatible kinds], (4)
     unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool
-    unblocked _ (CIrredCan { cc_status = BlockedCIS }) _ = False
+    unblocked _ (CIrredCan { cc_status = BlockedCIS {}}) _ = False
     unblocked checker ct pred = checker ct pred
 
     -- rigid_nom_eq, rigid_nom_tv_eq,
@@ -678,7 +676,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics
     has_gadt_match [] = False
     has_gadt_match (implic : implics)
       | PatSkol {} <- ic_info implic
-      , not (ic_no_eqs implic)
+      , ic_given_eqs implic /= NoGivenEqs
       , ic_warn_inaccessible implic
           -- Don't bother doing this if -Winaccessible-code isn't enabled.
           -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance.
@@ -888,7 +886,10 @@ maybeReportHoleError ctxt hole err
 
 -- Unlike maybeReportError, these "hole" errors are
 -- /not/ suppressed by cec_suppress.  We want to see them!
-maybeReportHoleError ctxt (Hole { hole_sort = TypeHole }) err
+maybeReportHoleError ctxt (Hole { hole_sort = hole_sort }) err
+  | case hole_sort of TypeHole       -> True
+                      ConstraintHole -> True
+                      _              -> False
   -- When -XPartialTypeSignatures is on, warnings (instead of errors) are
   -- generated for holes in partial type signatures.
   -- Unless -fwarn-partial-type-signatures is not on,
@@ -900,7 +901,7 @@ maybeReportHoleError ctxt (Hole { hole_sort = TypeHole }) err
        HoleWarn  -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err
        HoleDefer -> return ()
 
-maybeReportHoleError ctxt hole@(Hole { hole_sort = ExprHole _ }) err
+maybeReportHoleError ctxt hole err
   -- Otherwise this is a typed hole in an expression,
   -- but not for an out-of-scope variable (because that goes through a
   -- different function)
@@ -967,6 +968,8 @@ maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole ev_id })
   = return ()
 maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = TypeHole })
   = return ()
+maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = ConstraintHole })
+  = return ()
 
 tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
 -- Use the first reporter in the list whose predicate says True
@@ -1215,6 +1218,9 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ
       TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ))
                             2 (text "standing for" <+> quotes pp_hole_type_with_kind)
                        , tyvars_msg, type_hole_hint ]
+      ConstraintHole -> vcat [ hang (text "Found extra-constraints wildcard standing for")
+                                  2 (quotes $ pprType hole_ty)  -- always kind constraint
+                             , tyvars_msg, type_hole_hint ]
 
     pp_hole_type_with_kind
       | isLiftedTypeKind hole_kind
@@ -1628,7 +1634,7 @@ misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2
     eq_pred = ctEvPred ev
     orig    = ctEvOrigin ev
     level   = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel
-    givens  = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)]
+    givens  = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ]
               -- Keep only UserGivens that have some equalities.
               -- See Note [Suppress redundant givens during error reporting]
 
@@ -1686,7 +1692,10 @@ When reporting that GHC can't solve (a ~ c), there are two givens in scope:
 redundant), so it's not terribly useful to report it in an error message.
 To accomplish this, we discard any Implications that do not bind any
 equalities by filtering the `givens` selected in `misMatchOrCND` (based on
-the `ic_no_eqs` field of the Implication).
+the `ic_given_eqs` field of the Implication). Note that we discard givens
+that have no equalities whatsoever, but we want to keep ones with only *local*
+equalities, as these may be helpful to the user in understanding what went
+wrong.
 
 But this is not enough to avoid all redundant givens! Consider this example,
 from #15361:
@@ -1699,7 +1708,7 @@ Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope.
 The (* ~ *) part arises due the kinds of (:~~:) being unified. More
 importantly, (* ~ *) is redundant, so we'd like not to report it. However,
 the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its
-ic_no_eqs field), so the test above will keep it wholesale.
+ic_given_eqs field), so the test above will keep it wholesale.
 
 To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b)
 part. This works because mkMinimalBySCs eliminates reflexive equalities in
@@ -1741,7 +1750,7 @@ suggestAddSig ctxt ty1 _ty2
 
     -- 'find' returns the binders of an InferSkol for 'tv',
     -- provided there is an intervening implication with
-    -- ic_no_eqs = False (i.e. a GADT match)
+    -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match)
     find [] _ _ = []
     find (implic:implics) seen_eqs tv
        | tv `elem` ic_skols implic
@@ -1749,7 +1758,7 @@ suggestAddSig ctxt ty1 _ty2
        , seen_eqs
        = map fst prs
        | otherwise
-       = find implics (seen_eqs || not (ic_no_eqs implic)) tv
+       = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv
 
 --------------------
 misMatchMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> Report
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index e1077b883aa37ef345054b04ce82e84d3b246c7a..896ded667b90d6375d5dd4a65ba8bae24c64ac77 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -829,8 +829,7 @@ mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty
     do { fam_envs <- tcGetFamInstEnvs
        ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty
                -- Unification may not have normalised the type,
-               -- (see Note [Lazy flattening] in GHC.Tc.Solver.Flatten) so do it
-               -- here to make it as uncomplicated as possible.
+               -- so do it here to make it as uncomplicated as possible.
                -- Example: f :: [F Int] -> Bool
                -- should be rewritten to f :: [Char] -> Bool, if possible
                --
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 6e42b9e21e8925ae78f75ef77178d186f621470c..02464262222a5bccd9903fe5f30ee0c2082866a9 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -1189,6 +1189,11 @@ tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind
   = do { checkWiredInTyCon typeSymbolKindCon
        ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }
 
+--------- Wildcards
+
+tc_hs_type mode ty@(HsWildCardTy _)        ek
+  = tcAnonWildCardOcc NoExtraConstraint mode ty ek
+
 --------- Potentially kind-polymorphic types: call the "up" checker
 -- See Note [Future-proofing the type checker]
 tc_hs_type mode ty@(HsTyVar {})            ek = tc_infer_hs_type_ek mode ty ek
@@ -1197,7 +1202,6 @@ tc_hs_type mode ty@(HsAppKindTy{})         ek = tc_infer_hs_type_ek mode ty ek
 tc_hs_type mode ty@(HsOpTy {})             ek = tc_infer_hs_type_ek mode ty ek
 tc_hs_type mode ty@(HsKindSig {})          ek = tc_infer_hs_type_ek mode ty ek
 tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek
-tc_hs_type mode ty@(HsWildCardTy _)        ek = tcAnonWildCardOcc mode ty ek
 
 {-
 Note [Variable Specificity and Forall Visibility]
@@ -2071,8 +2075,9 @@ newNamedWildTyVar _name   -- Currently ignoring the "_x" wildcard name used in t
        ; return tyvar }
 
 ---------------------------
-tcAnonWildCardOcc :: TcTyMode -> HsType GhcRn -> Kind -> TcM TcType
-tcAnonWildCardOcc (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) })
+tcAnonWildCardOcc :: IsExtraConstraint
+                  -> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType
+tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) })
                   ty exp_kind
     -- hole_lvl: see Note [Checking partial type signatures]
     --           esp the bullet on nested forall types
@@ -2086,7 +2091,7 @@ tcAnonWildCardOcc (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) })
 
        ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes)
        ; when emit_holes $
-         emitAnonTypeHole wc_tv
+         emitAnonTypeHole is_extra wc_tv
          -- Why the 'when' guard?
          -- See Note [Wildcards in visible kind application]
 
@@ -2107,7 +2112,7 @@ tcAnonWildCardOcc (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) })
                      HM_FamPat  -> False
                      HM_VTA     -> False
 
-tcAnonWildCardOcc mode ty _
+tcAnonWildCardOcc _ mode ty _
 -- mode_holes is Nothing.  Should not happen, because renamer
 -- should already have rejected holes in unexpected places
   = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty)
@@ -3805,7 +3810,7 @@ tcPartialContext mode hs_theta
   | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta
   , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last
   = do { wc_tv_ty <- setSrcSpan wc_loc $
-                     tcAnonWildCardOcc mode ty constraintKind
+                     tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind
        ; theta <- mapM (tc_lhs_pred mode) hs_theta1
        ; return (theta, Just wc_tv_ty) }
   | otherwise
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index a1004e07c6691559ff0bf1a38928702f682ce1cb..5500c7692c8d1d3e8d2b2a112a1e8872c8e752ba 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -898,6 +898,8 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled
         ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs
                      -- Get location from monad, not from ex_tvs
                      -- This freshens: See Note [Freshen existentials]
+                     -- Why "super"? See Note [Binding when lookup up instances]
+                     -- in GHC.Core.InstEnv.
 
         ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys
               -- pat_ty' is type of the actual constructor application
diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs
index 620e585f8f3176b2cebd21a5ff229c3106a87c8e..65e91608b96b4ceccb82d5dc3f2a6aad6065ec9f 100644
--- a/compiler/GHC/Tc/Instance/Family.hs
+++ b/compiler/GHC/Tc/Instance/Family.hs
@@ -523,7 +523,7 @@ tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
 -- It is only used by the type inference engine (specifically, when
 -- solving representational equality), and hence it is careful to unwrap
 -- only if the relevant data constructor is in scope.  That's why
--- it get a GlobalRdrEnv argument.
+-- it gets a GlobalRdrEnv argument.
 --
 -- It is careful not to unwrap data/newtype instances if it can't
 -- continue unwrapping.  Such care is necessary for proper error
diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs
index b27168a1fc09ca4b9988aa68fb569d9a4f5f7bfa..fc1b607dbe2248095c5a07aa47b5926cdda97150 100644
--- a/compiler/GHC/Tc/Plugin.hs
+++ b/compiler/GHC/Tc/Plugin.hs
@@ -80,7 +80,6 @@ import GHC.Core.Class
 import GHC.Driver.Env
 import GHC.Utils.Outputable
 import GHC.Core.Type
-import GHC.Core.Coercion   ( BlockSubstFlag(..) )
 import GHC.Types.Id
 import GHC.Core.InstEnv
 import GHC.Data.FastString
@@ -181,7 +180,7 @@ newEvVar = unsafeTcPluginTcM . TcM.newEvVar
 
 -- | Create a fresh coercion hole.
 newCoercionHole :: PredType -> TcPluginM CoercionHole
-newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole YesBlockSubst
+newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole
 
 -- | Bind an evidence variable.  This must not be invoked from
 -- 'tcPluginInit' or 'tcPluginStop', or it will panic.
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index dc23ca54e675b417fd50da7f52ddc8323c7d4b53..8a2ff3911629e62c751ff865c0d56c5882f13960 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -258,13 +258,13 @@ floatKindEqualities wc = float_wc emptyVarSet wc
            | otherwise        = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs
 
     float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag Hole)
-    float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_no_eqs = no_eqs
+    float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs
                                       , ic_skols = skols, ic_status = status })
       | isInsolubleStatus status
       = Nothing   -- A short cut /plus/ we must keep track of IC_BadTelescope
       | otherwise
       = do { (simples, holes) <- float_wc new_trapping_tvs wanted
-           ; when (not (isEmptyBag simples) && not no_eqs) $
+           ; when (not (isEmptyBag simples) && given_eqs /= NoGivenEqs) $
              Nothing
                  -- If there are some constraints to float out, but we can't
                  -- because we don't float out past local equalities
@@ -938,7 +938,7 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
        ; psig_theta_vars <- mapM TcM.newEvVar psig_theta
        ; wanted_transformed_incl_derivs
             <- setTcLevel rhs_tclvl $
-               runTcSWithEvBinds ev_binds_var True $
+               runTcSWithEvBinds ev_binds_var $
                do { let loc         = mkGivenLoc rhs_tclvl UnkSkol $
                                       env_lcl tc_env
                         psig_givens = mkGivens loc psig_theta_vars
@@ -1025,13 +1025,13 @@ mkResidualConstraints rhs_tclvl ev_binds_var
                      then return emptyBag
                      else do implic1 <- newImplication
                              return $ unitBag $
-                                      implic1  { ic_tclvl  = rhs_tclvl
-                                               , ic_skols  = qtvs
-                                               , ic_given  = full_theta_vars
-                                               , ic_wanted = inner_wanted
-                                               , ic_binds  = ev_binds_var
-                                               , ic_no_eqs = False
-                                               , ic_info   = skol_info }
+                                      implic1  { ic_tclvl     = rhs_tclvl
+                                               , ic_skols     = qtvs
+                                               , ic_given     = full_theta_vars
+                                               , ic_wanted    = inner_wanted
+                                               , ic_binds     = ev_binds_var
+                                               , ic_given_eqs = MaybeGivenEqs
+                                               , ic_info      = skol_info }
 
         ; return (emptyWC { wc_simple = outer_simple
                           , wc_impl   = implics })}
@@ -1641,7 +1641,7 @@ simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints
 -- Solve the specified Wanted constraints
 -- Discard the evidence binds
 -- Discards all Derived stuff in result
--- Postcondition: fully zonked and unflattened constraints
+-- Postcondition: fully zonked
 simplifyWantedsTcM wanted
   = do { traceTc "simplifyWantedsTcM {" (ppr wanted)
        ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted))
@@ -1810,7 +1810,7 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
        -- ; when debugIsOn check_tc_level
 
          -- Solve the nested constraints
-       ; (no_given_eqs, given_insols, residual_wanted)
+       ; (has_given_eqs, given_insols, residual_wanted)
             <- nestImplicTcS ev_binds_var tclvl $
                do { let loc    = mkGivenLoc tclvl info (ic_env imp)
                         givens = mkGivens loc given_ids
@@ -1821,16 +1821,16 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
                         -- we want to retain derived equalities so we can float
                         -- them out in floatEqualities
 
-                  ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols
-                        -- Call getNoGivenEqs /after/ solveWanteds, because
+                  ; (has_eqs, given_insols) <- getHasGivenEqs tclvl
+                        -- Call getHasGivenEqs /after/ solveWanteds, because
                         -- solveWanteds can augment the givens, via expandSuperClasses,
                         -- to reveal given superclass equalities
 
-                  ; return (no_eqs, given_insols, residual_wanted) }
+                  ; return (has_eqs, given_insols, residual_wanted) }
 
        ; (floated_eqs, residual_wanted)
              <- floatEqualities skols given_ids ev_binds_var
-                                no_given_eqs residual_wanted
+                                has_given_eqs residual_wanted
 
        ; traceTcS "solveImplication 2"
            (ppr given_insols $$ ppr residual_wanted)
@@ -1838,13 +1838,13 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
              -- Don't lose track of the insoluble givens,
              -- which signal unreachable code; put them in ic_wanted
 
-       ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs
+       ; res_implic <- setImplicationStatus (imp { ic_given_eqs = has_given_eqs
                                                  , ic_wanted = final_wanted })
 
        ; evbinds <- TcS.getTcEvBindsMap ev_binds_var
        ; tcvs    <- TcS.getTcEvTyCoVars ev_binds_var
        ; traceTcS "solveImplication end }" $ vcat
-             [ text "no_given_eqs =" <+> ppr no_given_eqs
+             [ text "has_given_eqs =" <+> ppr has_given_eqs
              , text "floated_eqs =" <+> ppr floated_eqs
              , text "res_implic =" <+> ppr res_implic
              , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds)
@@ -2049,6 +2049,13 @@ simplifyHoles :: Bag Hole -> TcS (Bag Hole)
 simplifyHoles = mapBagM simpl_hole
   where
     simpl_hole :: Hole -> TcS Hole
+
+     -- See Note [Do not simplify ConstraintHoles]
+    simpl_hole h@(Hole { hole_sort = ConstraintHole }) = return h
+
+     -- other wildcards should be simplified for printing
+     -- we must do so here, and not in the error-message generation
+     -- code, because we have all the givens already set up
     simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc })
       = do { ty' <- flattenType loc ty
            ; return (h { hole_ty = ty' }) }
@@ -2093,6 +2100,41 @@ test T12227.
 But we don't get to discard all redundant equality superclasses, alas;
 see #15205.
 
+Note [Do not simplify ConstraintHoles]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before printing the inferred value for a type hole (a _ wildcard in
+a partial type signature), we simplify it w.r.t. any Givens. This
+makes for an easier-to-understand diagnostic for the user.
+
+However, we do not wish to do this for extra-constraint holes. Here is
+the example for why (partial-sigs/should_compile/T12844):
+
+  bar :: _ => FooData rngs
+  bar = foo
+
+  data FooData rngs
+
+  class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs
+
+  type family Head (xs :: [k]) where Head (x ': xs) = x
+
+GHC correctly infers that the extra-constraints wildcard on `bar`
+should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this constraint
+as a Given on the implication constraint for `bar`. The Hole for
+the _ is stored within the implication's WantedConstraints.
+When simplifyHoles is called, that constraint is already assumed as
+a Given. Simplifying with respect to it turns it into
+('(r, r') ~ '(r, r'), Foo rngs), which is disastrous.
+
+Furthermore, there is no need to simplify here: extra-constraints wildcards
+are filled in with the output of the solver, in chooseInferredQuantifiers
+(choose_psig_context), so they are already simplified. (Contrast to normal
+type holes, which are just bound to a meta-variable.) Avoiding the poor output
+is simple: just don't simplify extra-constraints wildcards.
+
+This is the only reason we need to track ConstraintHole separately
+from TypeHole in HoleSort.
+
 Note [Tracking redundant constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 With Opt_WarnRedundantConstraints, GHC can report which
@@ -2268,7 +2310,7 @@ approximateWC float_past_equalities wc
         concatMapBag (float_implic trapping_tvs) implics
     float_implic :: TcTyCoVarSet -> Implication -> Cts
     float_implic trapping_tvs imp
-      | float_past_equalities || ic_no_eqs imp
+      | float_past_equalities || ic_given_eqs imp == NoGivenEqs
       = float_wc new_trapping_tvs (ic_wanted imp)
       | otherwise   -- Take care with equalities
       = emptyCts    -- See (1) under Note [ApproximateWC]
@@ -2475,7 +2517,7 @@ no evidence for a fundep equality), but equality superclasses do matter (since
 they carry evidence).
 -}
 
-floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool
+floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> HasGivenEqs
                 -> WantedConstraints
                 -> TcS (Cts, WantedConstraints)
 -- Main idea: see Note [Float Equalities out of Implications]
@@ -2493,16 +2535,17 @@ floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool
 -- Subtleties: Note [Float equalities from under a skolem binding]
 --             Note [Skolem escape]
 --             Note [What prevents a constraint from floating]
-floatEqualities skols given_ids ev_binds_var no_given_eqs
+floatEqualities skols given_ids ev_binds_var has_given_eqs
                 wanteds@(WC { wc_simple = simples })
-  | not no_given_eqs  -- There are some given equalities, so don't float
+  | MaybeGivenEqs <- has_given_eqs  -- There are some given equalities, so don't float
   = return (emptyBag, wanteds)   -- Note [Float Equalities out of Implications]
 
   | otherwise
-  = do { -- First zonk: the inert set (from whence they came) is fully
-         -- zonked, but unflattening may have filled in unification
-         -- variables, and we /must/ see them.  Otherwise we may float
-         -- constraints that mention the skolems!
+  = do { -- First zonk: the inert set (from whence they came) is not
+         -- necessarily fully zonked; equalities are not kicked out
+         -- if a unification cannot make progress. See Note
+         -- [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad, which
+         -- describes how the inert set might not actually be inert.
          simples <- TcS.zonkSimples simples
        ; binds   <- TcS.getTcEvBindsMap ev_binds_var
 
@@ -2629,10 +2672,9 @@ happen.  In particular, float out equalities that are:
      of error messages.
 
   NB: generally we won't see (ty ~ alpha), with alpha on the right because
-  of Note [Unification variables on the left] in GHC.Tc.Utils.Unify.
-  But if we start with (F tys ~ alpha), it will orient as (fmv ~ alpha),
-  and unflatten back to (F tys ~ alpha). So we must look for alpha on
-  the right too.  Example T4494.
+  of Note [Unification variables on the left] in GHC.Tc.Utils.Unify,
+  but if we have (F tys ~ alpha) and alpha is untouchable, then it will
+  appear on the right.  Example T4494.
 
 * Nominal.  No point in floating (alpha ~R# ty), because we do not
   unify representational equalities even if alpha is touchable.
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index 7068d3176d3ce5a62706142beb02d9ddc308f731..60300b70f40dea3f2901b66deb0c4ef0dff50d48 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -1,10 +1,11 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE MultiWayIf #-}
 
 module GHC.Tc.Solver.Canonical(
      canonicalize,
      unifyDerived,
-     makeSuperClasses, maybeSym,
+     makeSuperClasses,
      StopOrContinue(..), stopWith, continueWith,
      solveCallStack    -- For GHC.Tc.Solver
   ) where
@@ -16,7 +17,7 @@ import GHC.Prelude
 import GHC.Tc.Types.Constraint
 import GHC.Core.Predicate
 import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.Unify( swapOverTyVars, metaTyVarUpdateOK, MetaTyVarUpdateResult(..) )
+import GHC.Tc.Utils.Unify
 import GHC.Tc.Utils.TcType
 import GHC.Core.Type
 import GHC.Tc.Solver.Flatten
@@ -28,15 +29,17 @@ 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
 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 )
+import GHC.Types.Var.Set( delVarSetList, anyVarSet )
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
+import GHC.Builtin.Types ( anyTypeOfKind )
 import GHC.Driver.Session( DynFlags )
 import GHC.Types.Name.Set
 import GHC.Types.Name.Reader
@@ -47,7 +50,7 @@ import GHC.Utils.Misc
 import GHC.Data.Bag
 import GHC.Utils.Monad
 import Control.Monad
-import Data.Maybe ( isJust )
+import Data.Maybe ( isJust, isNothing )
 import Data.List  ( zip4 )
 import GHC.Types.Basic
 
@@ -89,53 +92,46 @@ last time through, so we can skip the classification step.
 canonicalize :: Ct -> TcS (StopOrContinue Ct)
 canonicalize (CNonCanonical { cc_ev = ev })
   = {-# SCC "canNC" #-}
-    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
-      IrredPred {}          -> do traceTcS "canEvNC:irred" (ppr pred)
-                                  canIrred OtherCIS ev
-      ForAllPred tvs th p   -> do traceTcS "canEvNC:forall" (ppr pred)
-                                  canForAllNC ev tvs th p
-  where
-    pred = ctEvPred ev
+    canNC ev
 
 canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))
   = canForAll ev pend_sc
 
-canonicalize (CIrredCan { cc_ev = ev, cc_status = status })
-  | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev)
-  = -- For insolubles (all of which are equalities, do /not/ flatten the arguments
+canonicalize (CIrredCan { cc_ev = ev })
+  = canNC ev
+    -- Instead of flattening the evidence before classifying, it's possible we
+    -- can make progress without the flatten. Try this first.
+    -- For insolubles (all of which are equalities), do /not/ flatten the arguments
     -- In #14350 doing so led entire-unnecessary and ridiculously large
     -- type function expansion.  Instead, canEqNC just applies
     -- the substitution to the predicate, and may do decomposition;
     --    e.g. a ~ [a], where [G] a ~ [Int], can decompose
-    canEqNC ev eq_rel ty1 ty2
-
-  | otherwise
-  = canIrred status ev
 
 canonicalize (CDictCan { cc_ev = ev, cc_class  = cls
                        , cc_tyargs = xis, cc_pend_sc = pend_sc })
   = {-# SCC "canClass" #-}
     canClass ev cls xis pend_sc
 
-canonicalize (CTyEqCan { cc_ev = ev
-                       , cc_tyvar  = tv
-                       , cc_rhs    = xi
-                       , cc_eq_rel = eq_rel })
+canonicalize (CEqCan { cc_ev     = ev
+                     , cc_lhs    = lhs
+                     , cc_rhs    = rhs
+                     , cc_eq_rel = eq_rel })
   = {-# SCC "canEqLeafTyVarEq" #-}
-    canEqNC ev eq_rel (mkTyVarTy tv) xi
-      -- NB: Don't use canEqTyVar because that expects flattened types,
-      -- and tv and xi may not be flat w.r.t. an updated inert set
+    canEqNC ev eq_rel (canEqLHSType lhs) rhs
 
-canonicalize (CFunEqCan { cc_ev = ev
-                        , cc_fun    = fn
-                        , cc_tyargs = xis1
-                        , cc_fsk    = fsk })
-  = {-# SCC "canEqLeafFunEq" #-}
-    canCFunEqCan ev fn xis1 fsk
+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
+      IrredPred {}          -> do traceTcS "canEvNC:irred" (ppr pred)
+                                  canIrred ev
+      ForAllPred tvs th p   -> do traceTcS "canEvNC:forall" (ppr pred)
+                                  canForAllNC ev tvs th p
+  where
+    pred = ctEvPred ev
 
 {-
 ************************************************************************
@@ -206,8 +202,7 @@ canClass :: CtEvidence
 canClass ev cls tys pend_sc
   =   -- all classes do *nominal* matching
     ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )
-    do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys
-       ; MASSERT( isTcReflCo _kind_co )
+    do { (xis, cos) <- flattenArgsNom ev cls_tc tys
        ; let co = mkTcTyConAppCo Nominal cls_tc cos
              xi = mkClassPred cls xis
              mk_ct new_ev = CDictCan { cc_ev = new_ev
@@ -701,24 +696,27 @@ See also Note [Evidence for quantified constraints] in GHC.Core.Predicate.
 ************************************************************************
 -}
 
-canIrred :: CtIrredStatus -> CtEvidence -> TcS (StopOrContinue Ct)
+canIrred :: CtEvidence -> TcS (StopOrContinue Ct)
 -- Precondition: ty not a tuple and no other evidence form
-canIrred status ev
+canIrred ev
   = do { let pred = ctEvPred ev
        ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)
-       ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred
+       ; (xi,co) <- flatten ev pred -- co :: xi ~ pred
        ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
 
     do { -- Re-classify, in case flattening has improved its shape
-         -- Code is like the CNonCanonical case of canonicalize, except
+         -- Code is like the canNC, except
          -- that the IrredPred branch stops work
        ; case classifyPredType (ctEvPred new_ev) of
            ClassPred cls tys     -> canClassNC new_ev cls tys
            EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2
-           ForAllPred tvs th p   -> do traceTcS "canEvNC:forall" (ppr pred)
+           ForAllPred tvs th p   -> -- this is highly suspect; Quick Look
+                                    -- should never leave a meta-var filled
+                                    -- in with a polytype. This is #18987.
+                                    do traceTcS "canEvNC:forall" (ppr pred)
                                        canForAllNC ev tvs th p
            IrredPred {}          -> continueWith $
-                                    mkIrredCt status new_ev } }
+                                    mkIrredCt OtherCIS new_ev } }
 
 {- *********************************************************************
 *                                                                      *
@@ -817,11 +815,8 @@ canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct)
 -- We have a constraint (forall as. blah => C tys)
 canForAll ev pend_sc
   = do { -- First rewrite it to apply the current substitution
-         -- Do not bother with type-family reductions; we can't
-         -- do them under a forall anyway (c.f. Flatten.flatten_one
-         -- on a forall type)
          let pred = ctEvPred ev
-       ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred
+       ; (xi,co) <- flatten ev pred -- co :: xi ~ pred
        ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
 
     do { -- Now decompose into its pieces and solve it
@@ -988,19 +983,12 @@ can_eq_nc' _flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
 
 -- Then, get rid of casts
 can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
-  | not (isTyVarTy ty2)  -- See (3) in Note [Equalities with incompatible kinds]
+  | isNothing (canEqLHS_maybe ty2)  -- See (3) in Note [Equalities with incompatible kinds]
   = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2
 can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
-  | not (isTyVarTy ty1)  -- See (3) in Note [Equalities with incompatible kinds]
+  | isNothing (canEqLHS_maybe ty1)  -- See (3) in Note [Equalities with incompatible kinds]
   = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1
 
--- NB: pattern match on True: we want only flat types sent to canEqTyVar.
--- See also Note [No top-level newtypes on RHS of representational equalities]
-can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2
-  = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2
-can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2
-  = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1
-
 ----------------------
 -- Otherwise try to decompose
 ----------------------
@@ -1014,8 +1002,8 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
 -- Decompose FunTy: (s -> t) and (c => t)
 -- NB: don't decompose (Int -> blah) ~ (Show a => blah)
 can_eq_nc' _flat _rdr_env _envs ev eq_rel
-           (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _
-           (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _
+           (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   -- Don't decompose (Int -> blah) ~ (Show a => blah)
   , Just ty1a_rep <- getRuntimeRep_maybe ty1a  -- getRutimeRep_maybe:
   , Just ty1b_rep <- getRuntimeRep_maybe ty1b  -- see Note [Decomposing FunTy]
@@ -1026,11 +1014,14 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel
                               [am2, ty2a_rep, ty2b_rep, ty2a, ty2b]
 
 -- Decompose type constructor applications
--- NB: e have expanded type synonyms already
-can_eq_nc' _flat _rdr_env _envs ev eq_rel
-           (TyConApp tc1 tys1) _
-           (TyConApp tc2 tys2) _
-  | not (isTypeFamilyTyCon tc1)
+-- NB: we have expanded type synonyms already
+can_eq_nc' _flat _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
 
@@ -1041,22 +1032,51 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel
   = can_eq_nc_forall ev eq_rel s1 s2
 
 -- See Note [Canonicalising type applications] about why we require flat types
-can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _
-  | NomEq <- eq_rel
+-- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families
+-- NB: Only decompose AppTy for nominal equality. See Note [Decomposing equality]
+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_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _
-  | NomEq <- eq_rel
-  , Just (t1, s1) <- tcSplitAppTy_maybe ty1
-  = can_eq_app ev t1 s1 t2 s2
+
+-------------------
+-- Can't decompose.
+-------------------
 
 -- No similarity in type structure detected. Flatten and try again.
 can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
-  = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1
-       ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2
+  = do { (xi1, co1) <- flatten ev ps_ty1
+       ; (xi2, co2) <- flatten ev ps_ty2
        ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
        ; 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 flat types end up below here.
+----------------------------
+
+-- NB: pattern match on True: we want only flat 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 flattened 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)
@@ -1461,7 +1481,7 @@ can_eq_app :: CtEvidence       -- :: s1 t1 ~N s2 t2
 
 -- AppTys only decompose for nominal equality, so this case just leads
 -- to an irreducible constraint; see typecheck/should_compile/T10494
--- See Note [Decomposing equality], note {4}
+-- See Note [Decomposing AppTy at representational role]
 can_eq_app ev s1 t1 s2 t2
   | CtDerived {} <- ev
   = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]
@@ -1615,7 +1635,7 @@ In this Note, "decomposition" refers to taking the constraint
 where that notation indicates a list of new constraints, where the
 new constraints may have different flavours and different roles.
 
-The key property to consider is injectivity. When decomposing a Given the
+The key property to consider is injectivity. When decomposing a Given, the
 decomposition is sound if and only if T is injective in all of its type
 arguments. When decomposing a Wanted, the decomposition is sound (assuming the
 correct roles in the produced equality constraints), but it may be a guess --
@@ -1633,56 +1653,53 @@ Pursuing the details requires exploring three axes:
 * Role: Nominal vs. Representational
 * TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable
 
-(So a type variable isn't a TyCon, but it's convenient to put the AppTy case
+(A type variable isn't a TyCon, of course, but it's convenient to put the AppTy case
 in the same table.)
 
 Right away, we can say that Derived behaves just as Wanted for the purposes
 of decomposition. The difference between Derived and Wanted is the handling of
 evidence. Since decomposition in these cases isn't a matter of soundness but of
-guessing, we want the same behavior regardless of evidence.
+guessing, we want the same behaviour regardless of evidence.
 
 Here is a table (discussion following) detailing where decomposition of
    (T s1 ... sn) ~r (T t1 .. tn)
 is allowed.  The first four lines (Data types ... type family) refer
-to TyConApps with various TyCons T; the last line is for AppTy, where
-there is presumably a type variable at the head, so it's actually
-   (s s1 ... sn) ~r (t t1 .. tn)
+to TyConApps with various TyCons T; the last line is for AppTy, covering
+both where there is a type variable at the head and the case for an over-
+saturated type family.
 
-NOMINAL               GIVEN                       WANTED
+NOMINAL               GIVEN        WANTED                         WHERE
 
-Datatype               YES                         YES
-Newtype                YES                         YES
-Data family            YES                         YES
-Type family            YES, in injective args{1}   YES, in injective args{1}
-Type variable          YES                         YES
+Datatype               YES          YES                           canTyConApp
+Newtype                YES          YES                           canTyConApp
+Data family            YES          YES                           canTyConApp
+Type family            NO{1}        YES, in injective args{1}     canEqCanLHS2
+AppTy                  YES          YES                           can_eq_app
 
-REPRESENTATIONAL      GIVEN                       WANTED
+REPRESENTATIONAL      GIVEN        WANTED
 
-Datatype               YES                         YES
-Newtype                NO{2}                      MAYBE{2}
-Data family            NO{3}                      MAYBE{3}
-Type family             NO                          NO
-Type variable          NO{4}                       NO{4}
+Datatype               YES          YES                           canTyConApp
+Newtype                NO{2}       MAYBE{2}                canTyConApp(can_decompose)
+Data family            NO{3}       MAYBE{3}                canTyConApp(can_decompose)
+Type family            NO           NO                            canEqCanLHS2
+AppTy                  NO{4}        NO{4}                         can_eq_nc'
 
 {1}: Type families can be injective in some, but not all, of their arguments,
 so we want to do partial decomposition. This is quite different than the way
 other decomposition is done, where the decomposed equalities replace the original
-one. We thus proceed much like we do with superclasses: emitting new Givens
-when "decomposing" a partially-injective type family Given and new Deriveds
-when "decomposing" a partially-injective type family Wanted. (As of the time of
-writing, 13 June 2015, the implementation of injective type families has not
-been merged, but it should be soon. Please delete this parenthetical if the
-implementation is indeed merged.)
+one. We thus proceed much like we do with superclasses, emitting new Deriveds
+when "decomposing" a partially-injective type family Wanted. Injective type
+families have no corresponding evidence of their injectivity, so we cannot
+decompose an injective-type-family Given.
 
 {2}: See Note [Decomposing newtypes at representational role]
 
 {3}: Because of the possibility of newtype instances, we must treat
-data families like newtypes. See also Note [Decomposing newtypes at
-representational role]. See #10534 and test case
-typecheck/should_fail/T10534.
+data families like newtypes. See also
+Note [Decomposing newtypes at representational role]. See #10534 and
+test case typecheck/should_fail/T10534.
 
-{4}: Because type variables can stand in for newtypes, we conservatively do not
-decompose AppTys over representational equality.
+{4}: See Note [Decomposing AppTy at representational role]
 
 In the implementation of can_eq_nc and friends, we don't directly pattern
 match using lines like in the tables above, as those tables don't cover
@@ -1752,6 +1769,68 @@ Conclusion:
   * Decompose [W] N s ~R N t  iff there no given constraint that could
     later solve it.
 
+Note [Decomposing AppTy at representational role]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We never decompose AppTy at a representational role. For Givens, doing
+so is simply unsound: the LRCo coercion former requires a nominal-roled
+arguments. (See (1) for an example of why.) For Wanteds, decomposing
+would be sound, but it would be a guess, and a non-confluent one at that.
+
+Here is an example:
+
+    [G] g1 :: a ~R b
+    [W] w1 :: Maybe b ~R alpha a
+    [W] w2 :: alpha ~ Maybe
+
+Suppose we see w1 before w2. If we were to decompose, we would decompose
+this to become
+
+    [W] w3 :: Maybe ~R alpha
+    [W] w4 :: b ~ 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.) If we decomposed w1 to w3,w4, we would then get 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: never decompose AppTy with representational roles.
+
+(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
@@ -1820,8 +1899,8 @@ canEqFailure :: CtEvidence -> EqRel
 canEqFailure ev NomEq ty1 ty2
   = canEqHardFailure ev ty1 ty2
 canEqFailure ev ReprEq ty1 ty2
-  = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1
-       ; (xi2, co2) <- flatten FM_FlattenAll ev ty2
+  = do { (xi1, co1) <- flatten ev ty1
+       ; (xi2, co2) <- flatten ev ty2
             -- We must flatten the types before putting them in the
             -- inert set, so that we are sure to kick them out when
             -- new equalities become available
@@ -1836,8 +1915,8 @@ canEqHardFailure :: CtEvidence
 -- See Note [Make sure that insolubles are fully rewritten]
 canEqHardFailure ev ty1 ty2
   = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)
-       ; (s1, co1) <- flatten FM_SubstOnly ev ty1
-       ; (s2, co2) <- flatten FM_SubstOnly ev ty2
+       ; (s1, co1) <- flatten ev ty1
+       ; (s2, co2) <- flatten ev ty2
        ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2
        ; continueWith (mkIrredCt InsolubleCIS new_ev) }
 
@@ -1858,10 +1937,7 @@ unifyWanted etc to short-cut that work.
 Note [Canonicalising type applications]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Given (s1 t1) ~ ty2, how should we proceed?
-The simple things is to see if ty2 is of form (s2 t2), and
-decompose.  By this time s1 and s2 can't be saturated type
-function applications, because those have been dealt with
-by an earlier equation in can_eq_nc, so it is always sound to
+The simple thing is to see if ty2 is of form (s2 t2), and
 decompose.
 
 However, over-eager decomposition gives bad error messages
@@ -1921,9 +1997,9 @@ Suppose we're in this situation:
 where
   newtype Id a = Id a
 
-We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened
+We want to make sure canEqCanLHS sees [W] a ~R a, after b is flattened
 and the Id newtype is unwrapped. This is assured by requiring only flat
-types in canEqTyVar *and* having the newtype-unwrapping check above
+types in canEqCanLHS *and* having the newtype-unwrapping check above
 the tyvar check in can_eq_nc.
 
 Note [Occurs check error]
@@ -1942,104 +2018,83 @@ isInsolubleOccursCheck does.
 
 See also #10715, which induced this addition.
 
-Note [canCFunEqCan]
-~~~~~~~~~~~~~~~~~~~
-Flattening the arguments to a type family can change the kind of the type
-family application. As an easy example, consider (Any k) where (k ~ Type)
-is in the inert set. The original (Any k :: k) becomes (Any Type :: Type).
-The problem here is that the fsk in the CFunEqCan will have the old kind.
-
-The solution is to come up with a new fsk/fmv of the right kind. For
-givens, this is easy: just introduce a new fsk and update the flat-cache
-with the new one. For wanteds, we want to solve the old one if favor of
-the new one, so we use dischargeFmv. This also kicks out constraints
-from the inert set; this behavior is correct, as the kind-change may
-allow more constraints to be solved.
-
-We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case
-if we really need to.  Of course `flattenArgsNom` should return `Refl`
-whenever possible, but #15577 was an infinite loop because even
-though the coercion was homo-kinded, `kind_co` was not `Refl`, so we
-made a new (identical) CFunEqCan, and then the entire process repeated.
--}
+Note [Put touchable variables on the left]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Ticket #10009, a very nasty example:
 
-canCFunEqCan :: CtEvidence
-             -> TyCon -> [TcType]   -- LHS
-             -> TcTyVar             -- RHS
-             -> TcS (StopOrContinue Ct)
--- ^ Canonicalise a CFunEqCan.  We know that
---     the arg types are already flat,
--- and the RHS is a fsk, which we must *not* substitute.
--- So just substitute in the LHS
-canCFunEqCan ev fn tys fsk
-  = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys
-                        -- cos :: tys' ~ tys
-
-       ; let lhs_co  = mkTcTyConAppCo Nominal fn cos
-                        -- :: F tys' ~ F tys
-             new_lhs = mkTyConApp fn tys'
-
-             flav    = ctEvFlavour ev
-       ; (ev', fsk')
-           <- if isTcReflexiveCo kind_co   -- See Note [canCFunEqCan]
-              then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs)
-                      ; let fsk_ty = mkTyVarTy fsk
-                      ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty
-                                                 lhs_co (mkTcNomReflCo fsk_ty)
-                      ; return (ev', fsk) }
-              else do { traceTcS "canCFunEqCan: non-refl" $
-                        vcat [ text "Kind co:" <+> ppr kind_co
-                             , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk)
-                             , text "LHS:" <+> hang (ppr (mkTyConApp fn tys))
-                                                  2 (dcolon <+> ppr (tcTypeKind (mkTyConApp fn tys)))
-                             , text "New LHS" <+> hang (ppr new_lhs)
-                                                     2 (dcolon <+> ppr (tcTypeKind new_lhs)) ]
-                      ; (ev', new_co, new_fsk)
-                          <- newFlattenSkolem flav (ctEvLoc ev) fn tys'
-                      ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co
-                               -- sym lhs_co :: F tys ~ F tys'
-                               -- new_co     :: F tys' ~ new_fsk
-                               -- co         :: F tys ~ (new_fsk |> kind_co)
-                            co = mkTcSymCo lhs_co `mkTcTransCo`
-                                 mkTcCoherenceRightCo Nominal
-                                                      (mkTyVarTy new_fsk)
-                                                      kind_co
-                                                      new_co
-
-                      ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev)
-                      ; dischargeFunEq ev fsk co xi
-                      ; return (ev', new_fsk) }
-
-       ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev')
-       ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn
-                                 , cc_tyargs = tys', cc_fsk = fsk' }) }
+    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
+             [WD] w1 : UnF (F beta) ~ beta
+             [WD] 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
+
+    [D] w3 : F beta ~ F a
+
+then (after emitting shadow Deriveds, etc. See GHC.Tc.Solver.Monad
+Note [The improvement story and derived shadows]) we'll kick w1 out of the inert
+set (it mentions the LHS of w3). We then rewrite w1 to
+
+    [D] w4 : UnF (F a) ~ beta
+
+and then, using g1, to
+
+    [D] 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 flatten 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.
+
+-}
 
 ---------------------
-canEqTyVar :: CtEvidence          -- ev :: lhs ~ rhs
-           -> EqRel -> SwapFlag
-           -> TcTyVar               -- tv1
-           -> TcType                -- lhs: pretty lhs, already flat
-           -> TcType -> TcType      -- rhs: already flat
-           -> TcS (StopOrContinue Ct)
-canEqTyVar ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2
+canEqCanLHS :: CtEvidence          -- ev :: lhs ~ rhs
+            -> EqRel -> SwapFlag
+            -> CanEqLHS              -- lhs (or, if swapped, rhs)
+            -> TcType                -- lhs: pretty lhs, already flat
+            -> TcType -> TcType      -- rhs: already flat
+            -> TcS (StopOrContinue Ct)
+canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
   | k1 `tcEqType` k2
-  = canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2
+  = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
 
   | otherwise
-  = canEqTyVarHetero ev eq_rel swapped tv1 ps_xi1 k1 xi2 ps_xi2 k2
+  = canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 k1 xi2 ps_xi2 k2
 
   where
-    k1 = tyVarKind tv1
+    k1 = canEqLHSKind lhs1
     k2 = tcTypeKind xi2
 
-canEqTyVarHetero :: CtEvidence         -- :: (tv1 :: ki1) ~ (xi2 :: ki2)
-                 -> EqRel -> SwapFlag
-                 -> TcTyVar -> TcType  -- tv1, pretty tv1
-                 -> TcKind             -- ki1
-                 -> TcType -> TcType   -- xi2, pretty xi2 :: ki2
-                 -> TcKind             -- ki2
-                 -> TcS (StopOrContinue Ct)
-canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2
+canEqCanLHSHetero :: CtEvidence         -- :: (xi1 :: ki1) ~ (xi2 :: ki2)
+                  -> EqRel -> SwapFlag
+                  -> CanEqLHS -> TcType -- xi1, pretty xi1
+                  -> TcKind             -- ki1
+                  -> TcType -> TcType   -- xi2, pretty xi2 :: ki2
+                  -> TcKind             -- ki2
+                  -> TcS (StopOrContinue Ct)
+canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2
   -- See Note [Equalities with incompatible kinds]
   = do { kind_co <- emit_kind_co   -- :: ki2 ~N ki1
 
@@ -2050,15 +2105,14 @@ canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2
              rhs_co  = mkTcGReflLeftCo role xi2 kind_co
                -- rhs_co :: (xi2 |> kind_co) ~ xi2
 
-             lhs'   = mkTyVarTy tv1  -- same as old lhs
-             lhs_co = mkTcReflCo role lhs'
+             lhs_co = mkTcReflCo role xi1
 
        ; traceTcS "Hetero equality gives rise to kind equality"
            (ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ])
-       ; type_ev <- rewriteEqEvidence ev swapped lhs' rhs' lhs_co rhs_co
+       ; type_ev <- rewriteEqEvidence ev swapped xi1 rhs' lhs_co rhs_co
 
           -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more
-       ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' }
+       ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 rhs' ps_rhs' }
   where
     emit_kind_co :: TcS CoercionN
     emit_kind_co
@@ -2071,9 +2125,10 @@ canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2
       | otherwise
       = unifyWanted kind_loc Nominal ki2 ki1
 
+    xi1      = canEqLHSType lhs1
     loc      = ctev_loc ev
     role     = eqRelRole eq_rel
-    kind_loc = mkKindLoc (mkTyVarTy tv1) xi2 loc
+    kind_loc = mkKindLoc xi1 xi2 loc
     kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki2 ki1
 
     maybe_sym = case swapped of
@@ -2082,104 +2137,236 @@ canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2
           NotSwapped -> mkTcSymCo
 
 -- guaranteed that tcTypeKind lhs == tcTypeKind rhs
-canEqTyVarHomo :: CtEvidence
-               -> EqRel -> SwapFlag
-               -> TcTyVar                -- lhs: tv1
-               -> TcType                 -- pretty lhs, flat
-               -> TcType -> TcType       -- rhs, flat
-               -> TcS (StopOrContinue Ct)
-canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 _
-  | Just (tv2, _) <- tcGetCastedTyVar_maybe xi2
-  , tv1 == tv2
-  = canEqReflexive ev eq_rel (mkTyVarTy tv1)
-    -- we don't need to check co because it must be reflexive
-
-    -- this guarantees (TyEq:TV)
-  | Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2
-  , swapOverTyVars (isGiven ev) tv1 tv2
-  = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)
-       ; let role    = eqRelRole eq_rel
-             sym_co2 = mkTcSymCo co2
-             ty1     = mkTyVarTy tv1
-             new_lhs = ty1 `mkCastTy` sym_co2
-             lhs_co  = mkTcGReflLeftCo role ty1 sym_co2
+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` mkTcSymMCo mco) mco
 
-             new_rhs = mkTyVarTy tv2
-             rhs_co  = mkTcGReflRightCo role new_rhs co2
+  | otherwise
+  = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2
 
-       ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co
+  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
+  = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2)
+
+         -- emit derived 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
+               = []
+
+       ; unless (isGiven ev) $
+         mapM_ (unifyDerived (ctEvLoc ev) Nominal) inj_eqns
+
+       ; tclvl <- getTcLevel
        ; dflags <- getDynFlags
-       ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_xi1 `mkCastTy` sym_co2) }
+       ; 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
+               | MTVU_OK ()  <- checkTyFamEq dflags fun_tc2 fun_args2
+                                             (mkTyConApp fun_tc1 fun_args1)
+               , MTVU_Occurs <- checkTyFamEq dflags 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
 
-canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_xi2
-  = do { dflags <- getDynFlags
-       ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_xi2 }
-
--- The RHS here is either not a casted tyvar, or it's a tyvar but we want
--- to rewrite the LHS to the RHS (as per swapOverTyVars)
-canEqTyVar2 :: DynFlags
-            -> CtEvidence   -- lhs ~ rhs (or, if swapped, orhs ~ olhs)
-            -> EqRel
-            -> SwapFlag
-            -> TcTyVar                  -- lhs = tv, flat
-            -> TcType                   -- rhs, flat
-            -> TcS (StopOrContinue Ct)
--- LHS is an inert type variable,
--- and RHS is fully rewritten, but with type synonyms
+  where
+    sym_mco = mkTcSymMCo 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 we can unify the variable, 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
+-- It would probably work to always put the variable on the left, but we think
+-- it would be less efficient.
+canEqTyVarFunEq :: CtEvidence               -- :: lhs ~ (rhs |> mco)
+                                            -- or (rhs |> mco) ~ lhs if swapped
+                -> EqRel -> SwapFlag
+                -> TyVar -> TcType          -- lhs, pretty lhs
+                -> TyCon -> [Xi] -> TcType  -- rhs fun, rhs 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 { tclvl <- getTcLevel
+       ; dflags <- getDynFlags
+       ; if | isTouchableMetaTyVar tclvl tv1
+              , MTVU_OK _ <- checkTyVarEq dflags YesTypeFamilies tv1 (ps_xi2 `mkCastTyMCo` mco)
+              -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1)
+                                                     (ps_xi2 `mkCastTyMCo` mco)
+            | 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 = mkTcSymMCo 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, pretty rhs
+                  -> 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)
--- the "flat" requirement guarantees (TyEq:AFF)
 -- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqTyVarHomo
-canEqTyVar2 dflags ev eq_rel swapped tv1 rhs
-    -- this next line checks also for coercion holes; see
-    -- Note [Equalities with incompatible kinds]
-  | MTVU_OK rhs' <- mtvu  -- No occurs check
+
+  = do { dflags <- getDynFlags
+       ; new_ev <- rewriteEqEvidence ev swapped lhs_ty rhs rewrite_co1 rewrite_co2
+
      -- Must do the occurs check even on tyvar/tyvar
      -- equalities, in case have  x ~ (y :: ..x...)
      -- #12593
      -- guarantees (TyEq:OC), (TyEq:F), and (TyEq:H)
-  = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2
-       ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1
-                                , cc_rhs = rhs', cc_eq_rel = eq_rel }) }
+    -- this next line checks also for coercion holes (TyEq:H); see
+    -- Note [Equalities with incompatible kinds]
+       ; case canEqOK dflags eq_rel lhs rhs of
+           CanEqOK ->
+             do { traceTcS "canEqOK" (ppr lhs $$ ppr rhs)
+                ; continueWith (CEqCan { cc_ev = new_ev, cc_lhs = lhs
+                                       , cc_rhs = rhs, cc_eq_rel = eq_rel }) }
+       -- it is possible that cc_rhs mentions the LHS if the LHS is a type
+       -- family. This will cause later flattening to potentially loop, but
+       -- that will be caught by the depth counter. The other option is an
+       -- occurs-check for a function application, which seems awkward.
+
+           CanEqNotOK status
+                -- See Note [Type variable cycles in Givens]
+             | OtherCIS <- status
+             , Given <- ctEvFlavour ev
+             , TyVarLHS lhs_tv <- lhs
+             , not (isCycleBreakerTyVar lhs_tv) -- See Detail (7) of Note
+             , NomEq <- eq_rel
+             -> do { traceTcS "canEqCanLHSFinish breaking a cycle" (ppr lhs $$ ppr rhs)
+                   ; new_rhs <- breakTyVarCycle (ctEvLoc ev) rhs
+                   ; traceTcS "new RHS:" (ppr new_rhs)
+                   ; let new_pred   = mkPrimEqPred (mkTyVarTy lhs_tv) new_rhs
+                         new_new_ev = new_ev { ctev_pred = new_pred }
+                           -- See Detail (6) of Note [Type variable cycles in Givens]
+
+                   ; if anyRewritableTyVar True NomEq (\ _ tv -> tv == lhs_tv) new_rhs
+                     then do { traceTcS "Note [Type variable cycles in Givens] Detail (1)"
+                                        (ppr new_new_ev)
+                             ; continueWith (mkIrredCt status new_ev) }
+                     else continueWith (CEqCan { cc_ev = new_new_ev, cc_lhs = lhs
+                                               , cc_rhs = new_rhs, cc_eq_rel = eq_rel }) }
 
-  | otherwise  -- For some reason (occurs check, or forall) we can't unify
                -- We must not use it for further rewriting!
-  = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs $$ ppr mtvu)
-       ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2
-       ; let status | isInsolubleOccursCheck eq_rel tv1 rhs
-                    = InsolubleCIS
-             -- If we have a ~ [a], it is not canonical, and in particular
-             -- we don't want to rewrite existing inerts with it, otherwise
-             -- we'd risk divergence in the constraint solver
-
-                    | MTVU_HoleBlocker <- mtvu
-                    = BlockedCIS
-             -- This is the case detailed in
-             -- Note [Equalities with incompatible kinds]
-
-                    | otherwise
-                    = OtherCIS
-             -- A representational equality with an occurs-check problem isn't
-             -- insoluble! For example:
-             --   a ~R b a
-             -- We might learn that b is the newtype Id.
-             -- But, the occurs-check certainly prevents the equality from being
-             -- canonical, and we might loop if we were to use it in rewriting.
-
-       ; continueWith (mkIrredCt status new_ev) }
+             | otherwise
+             -> do { traceTcS "canEqCanLHSFinish can't make a canonical" (ppr lhs $$ ppr rhs)
+                   ; continueWith (mkIrredCt status new_ev) } }
   where
-    mtvu = metaTyVarUpdateOK dflags tv1 rhs
-           -- Despite the name of the function, tv1 may not be a
-           -- unification variable; we are really checking that this
-           -- equality is ok to be used to rewrite others, i.e.  that
-           -- it satisfies the conditions for CTyEqCan
-
     role = eqRelRole eq_rel
 
-    lhs = mkTyVarTy tv1
+    lhs_ty = canEqLHSType lhs
 
-    rewrite_co1  = mkTcReflCo role lhs
+    rewrite_co1  = mkTcReflCo role lhs_ty
     rewrite_co2  = mkTcReflCo role rhs
 
 -- | Solve a reflexive equality constraint
@@ -2192,6 +2379,96 @@ canEqReflexive ev eq_rel ty
                                mkTcReflCo (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 ev swapped new_lhs new_rhs lhs_co rhs_co
+  where
+    new_lhs = lhs `mkCastTyMCo` sym_mco
+    lhs_co  = mkTcGReflLeftMCo role lhs sym_mco
+
+    new_rhs = rhs
+    rhs_co  = mkTcGReflRightMCo role rhs mco
+
+    sym_mco = mkTcSymMCo mco
+    role    = eqRelRole eq_rel
+
+---------------------------------------------
+-- | Result of checking whether a RHS is suitable for pairing
+-- with a CanEqLHS in a CEqCan.
+data CanEqOK
+  = CanEqOK                   -- RHS is good
+  | CanEqNotOK CtIrredStatus  -- don't proceed; explains why
+
+instance Outputable CanEqOK where
+  ppr CanEqOK             = text "CanEqOK"
+  ppr (CanEqNotOK status) = text "CanEqNotOK" <+> ppr status
+
+-- | This function establishes most of the invariants needed to make
+-- a CEqCan.
+--
+--   TyEq:OC: Checked here.
+--   TyEq:F:  Checked here.
+--   TyEq:K:  assumed; ASSERTed here (that is, kind(lhs) = kind(rhs))
+--   TyEq:N:  assumed; ASSERTed here (if eq_rel is R, rhs is not a newtype)
+--   TyEq:TV: not checked (this is hard to check)
+--   TyEq:H:  Checked here.
+canEqOK :: DynFlags -> EqRel -> CanEqLHS -> Xi -> CanEqOK
+canEqOK dflags eq_rel lhs rhs
+  = ASSERT( good_rhs )
+    case checkTypeEq dflags YesTypeFamilies lhs rhs of
+      MTVU_OK ()       -> CanEqOK
+      MTVU_Bad         -> CanEqNotOK OtherCIS
+                 -- Violation of TyEq:F
+
+      MTVU_HoleBlocker -> CanEqNotOK (BlockedCIS holes)
+        where holes = coercionHolesOfType rhs
+                 -- This is the case detailed in
+                 -- Note [Equalities with incompatible kinds]
+                 -- Violation of TyEq:H
+
+                 -- These are both a violation of TyEq:OC, but we
+                 -- want to differentiate for better production of
+                 -- error messages
+      MTVU_Occurs | TyVarLHS tv <- lhs
+                  , isInsolubleOccursCheck eq_rel tv rhs -> CanEqNotOK InsolubleCIS
+                 -- If we have a ~ [a], it is not canonical, and in particular
+                 -- we don't want to rewrite existing inerts with it, otherwise
+                 -- we'd risk divergence in the constraint solver
+
+                 -- NB: no occCheckExpand here; see Note [Flattening synonyms]
+                 -- in GHC.Tc.Solver.Flatten
+
+                  | otherwise                            -> CanEqNotOK OtherCIS
+                 -- A representational equality with an occurs-check problem isn't
+                 -- insoluble! For example:
+                 --   a ~R b a
+                 -- We might learn that b is the newtype Id.
+                 -- But, the occurs-check certainly prevents the equality from being
+                 -- canonical, and we might loop if we were to use it in rewriting.
+
+                 -- This case also include type family occurs-check errors, which
+                 -- are not generally insoluble
+
+  where
+    good_rhs    = kinds_match && not bad_newtype
+
+    lhs_kind    = canEqLHSKind lhs
+    rhs_kind    = tcTypeKind rhs
+
+    kinds_match = lhs_kind `tcEqType` rhs_kind
+
+    bad_newtype | ReprEq <- eq_rel
+                , Just tc <- tyConAppTyCon_maybe rhs
+                = isNewTyCon tc
+                | otherwise
+                = False
+
 {- Note [Equalities with incompatible kinds]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 What do we do when we have an equality
@@ -2213,8 +2490,17 @@ where
   noDerived G = G
   noDerived _ = W
 
-For Wanted/Derived, the [X] constraint is "blocked" (not CTyEqCan, is CIrred)
-until the k1~k2 constraint solved: Wrinkle (2).
+For reasons described in Wrinkle (2) below, we want the [X] constraint to be "blocked";
+that is, it should be put aside, and not used to rewrite any other constraint,
+until the kind-equality on which it depends (namely 'co' above) is solved.
+To achieve this
+* The [X] constraint is a CIrredCan
+* With a cc_status of BlockedCIS bchs
+* Where 'bchs' is the set of "blocking coercion holes".  The blocking coercion
+  holes are the free coercion holes of [X]'s type
+* When all the blocking coercion holes in the CIrredCan are filled (solved),
+  we convert [X] to a CNonCanonical and put it in the work list.
+All this is described in more detail in Wrinkle (2).
 
 Wrinkles:
 
@@ -2232,39 +2518,59 @@ Wrinkles:
      in GHC.Tc.Types.Constraint. The problem is about poor error messages. See #11198 for
      tales of destruction.
 
-     So, we have an invariant on CTyEqCan (TyEq:H) that the RHS does not have
-     any coercion holes. This is checked in metaTyVarUpdateOK. We also
-     must be sure to kick out any constraints that mention coercion holes
-     when those holes get filled in.
-
-     (2a) We don't want to do this for CoercionHoles that witness
-          CFunEqCans (that are produced by the flattener), as these will disappear
-          once we unflatten. So we remember in the CoercionHole structure
-          whether the presence of the hole should block substitution or not.
-          A bit gross, this.
-
-     (2b) We must now absolutely make sure to kick out any constraints that
-          mention a newly-filled-in coercion hole. This is done in
-          kickOutAfterFillingCoercionHole.
+     So, we have an invariant on CEqCan (TyEq:H) that the RHS does not have
+     any coercion holes. This is checked in checkTypeEq. Any equalities that
+     have such an RHS are turned into CIrredCans with a BlockedCIS status. We also
+     must be sure to kick out any such CIrredCan constraints that mention coercion holes
+     when those holes get filled in, so that the unification step can now proceed.
+
+     (2a) We must now kick out any constraints that mention a newly-filled-in
+          coercion hole, but only if there are no more remaining coercion
+          holes. This is done in kickOutAfterFillingCoercionHole. The extra
+          check that there are no more remaining holes avoids needless work
+          when rewriting evidence (which fills coercion holes) and aids
+          efficiency.
+
+          Moreover, kicking out when there are remaining unfilled holes can
+          cause a loop in the solver in this case:
+               [W] w1 :: (ty1 :: F a) ~ (ty2 :: s)
+          After canonicalisation, we discover that this equality is heterogeneous.
+          So we emit
+               [W] co_abc :: F a ~ s
+          and preserve the original as
+               [W] w2 :: (ty1 |> co_abc) ~ ty2    (blocked on co_abc)
+          Then, co_abc comes becomes the work item. It gets swapped in
+          canEqCanLHS2 and then back again in canEqTyVarFunEq. We thus get
+          co_abc := sym co_abd, and then co_abd := sym co_abe, with
+               [W] co_abe :: F a ~ s
+          This process has filled in co_abc. Suppose w2 were kicked out.
+          When it gets processed,
+          would get this whole chain going again. The solution is to
+          kick out a blocked constraint only when the result of filling
+          in the blocking coercion involves no further blocking coercions.
+          Alternatively, we could be careful not to do unnecessary swaps during
+          canonicalisation, but that seems hard to do, in general.
 
  (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the
      algorithm detailed here, producing [W] co :: k2 ~ k1, and adding
      [W] (a :: k1) ~ ((rhs |> 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 (2b).
+     the irreducible as described in (2a).
      But now, during canonicalization, we see the cast
-     and remove it, in canEqCast. By the time we get into canEqTyVar, the equality
+     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 tyvar. And this is an improvement regardless:
+     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'.
 
- (4) Reporting an error for a constraint that is blocked only because
-     of wrinkle (2) is hard: what would we say to users? And we don't
+ (4) Reporting an error for a constraint that is blocked with status BlockedCIS
+     is hard: what would we say to users? And we don't
      really need to report, because if a constraint is blocked, then
      there is unsolved wanted blocking it; that unsolved wanted will
      be reported. We thus push such errors to the bottom of the queue
@@ -2328,7 +2634,211 @@ 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 canEqTyVar.
+as possible.  Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS.
+
+Note [Type variable cycles in Givens]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this situation (from indexed-types/should_compile/GivenLoop):
+
+  instance C (Maybe b)
+  [G] a ~ Maybe (F a)
+  [W] C a
+
+In order to solve the Wanted, we must use the Given to rewrite `a` to
+Maybe (F a). But note that the Given has an occurs-check failure, and
+so we can't straightforwardly add the Given to the inert set.
+
+The key idea is to replace the (F a) in the RHS of the Given with a
+fresh variable, which we'll call a CycleBreakerTv, or cbv. Then, emit
+a new Given to connect cbv with F a. So our situation becomes
+
+  instance C (Maybe b)
+  [G] a ~ Maybe cbv
+  [G] F a ~ cbv
+  [W] C a
+
+Note the orientation of the second Given. 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. This causes
+no trouble.)
+
+More generally, we detect this scenario by the following characteristics:
+ - a Given CEqCan constraint
+ - with a tyvar on its LHS
+ - with a soluble occurs-check failure
+ - and a nominal equality
+
+Having identified the scenario, we wish to replace all type family
+applications on the RHS with fresh metavariables (with MetaInfo
+CycleBreakerTv). This is done in breakTyVarCycle. These metavariables are
+untouchable, but we also emit Givens relating the fresh variables to the type
+family applications they replace.
+
+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 breakTyVarCycle.
+
+That is:
+
+We transform
+  [G] g : a ~ ...(F a)...
+to
+  [G] (Refl a) : F a ~ cbv      -- CEqCan
+  [G] g        : a ~ ...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 a`.
+  No one else fills in cycle-breakers!
+* In inert_cycle_breakers, we remember the (cbv, F a) pair; that is, we
+  remember the /original/ type.  The [G] F a ~ cbv constraint may be rewritten
+  by other givens (eg if we have another [G] a ~ (b,c), but at the end we
+  still fill in with cbv := F a
+* This fill-in is done when solving is complete, by restoreTyVarCycles
+  in nestImplicTcS and runTcSWithEvBinds.
+* The evidence for the new `F a ~ cbv` constraint is Refl, because we know this fill-in is
+  ultimately going to happen.
+
+There are drawbacks of this approach:
+
+ 1. We apply this trick only for Givens, never for Wanted or Derived.
+    It wouldn't make sense for Wanted, because Wanted never rewrite.
+    But it's conceivable that a Derived would benefit from this all.
+    I doubt it would ever happen, though, so I'm holding off.
+
+ 2. 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] a ~ forall b. ... a ....   Until we have a type
+     family that can pull the body out from a forall, 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 breakTyVarCycle actually
+     succeeds in getting rid of all occurrences of the offending variable.
+     If one is hidden under a forall, this won't be true. So we perform
+     an additional check after performing the substitution.
+
+     Skipping this check causes typecheck/should_fail/GivenForallLoop 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.
+     (There is no worry about unifying a meta-variable here: this Note is
+      only about Givens.)
+
+ (3) As we're substituting, 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.
+
+ (5) The approach here is inefficient. For instance, we could choose to
+     affect only type family applications that mention the offending variable:
+     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, always
+     tickled by a user-written Given. The investment to craft a clever,
+     performant solution seems unworthwhile.
+
+ (6) We often get the predicate associated with a constraint from its
+     evidence. We thus must not only make sure the generated CEqCan's
+     fields have the updated RHS type, but we must also update the
+     evidence itself. As in Detail (4), we don't need to change the
+     evidence term (as in e.g. rewriteEqEvidence) because the cycle
+     breaker variables are all zonked away by the time we examine the
+     evidence. That is, we must set the ctev_pred of the ctEvidence.
+     This is implemented in canEqCanLHSFinish, with a reference to
+     this detail.
+
+ (7) We don't wish to apply this magic to CycleBreakerTvs themselves.
+     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
+     if the var is already a CycleBreakerTv. Instead, we mark this
+     final Given as a CIrredCan with an OtherCIS status (it's not
+     insoluble).
+
+     NB: When filling in CycleBreakerTvs, we fill them in with what
+     they originally stood for (e.g. cbv1 := TF a, cbv2 := TF Int),
+     not what may be in a rewritten constraint.
+
+     Not breaking cycles fursther makes sense, because
+     we only want to break cycles for user-written loopy Givens, and
+     a CycleBreakerTv certainly isn't user-written.
+
+NB: This same situation (an equality like b ~ Maybe (F b)) can arise with
+Wanteds, but we have no concrete case incentivising special treatment. It
+would just be a CIrredCan.
 
 -}
 
@@ -2479,26 +2989,22 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
 
   | CtGiven { ctev_evar = old_evar } <- old_ev
   = do { let new_tm = evCoercion (lhs_co
-                                  `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar)
+                                  `mkTcTransCo` maybeTcSymCo swapped (mkTcCoVarCo old_evar)
                                   `mkTcTransCo` mkTcSymCo rhs_co)
        ; newGivenEvVar loc' (new_pred, new_tm) }
 
   | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev
-  = case dest of
-      HoleDest hole ->
-        do { (new_ev, hole_co) <- newWantedEq_SI (ch_blocker hole) si loc'
-                                                 (ctEvRole old_ev) nlhs nrhs
-                   -- The "_SI" variant ensures that we make a new Wanted
-                   -- with the same shadow-info as the existing one (#16735)
-           ; let co = maybeSym swapped $
-                      mkSymCo lhs_co
-                      `mkTransCo` hole_co
-                      `mkTransCo` rhs_co
-           ; setWantedEq dest co
-           ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])
-           ; return new_ev }
-
-      _ -> panic "rewriteEqEvidence"
+  = do { (new_ev, hole_co) <- newWantedEq_SI si loc'
+                                             (ctEvRole old_ev) nlhs nrhs
+               -- The "_SI" variant ensures that we make a new Wanted
+               -- with the same shadow-info as the existing one (#16735)
+       ; let co = maybeTcSymCo swapped $
+                  mkSymCo lhs_co
+                  `mkTransCo` hole_co
+                  `mkTransCo` rhs_co
+       ; setWantedEq dest co
+       ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])
+       ; return new_ev }
 
 #if __GLASGOW_HASKELL__ <= 810
   | otherwise
@@ -2513,7 +3019,14 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
     loc      = ctEvLoc old_ev
     loc'     = bumpCtLocDepth loc
 
-{- Note [unifyWanted and unifyDerived]
+{-
+************************************************************************
+*                                                                      *
+              Unification
+*                                                                      *
+************************************************************************
+
+Note [unifyWanted and unifyDerived]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 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.
@@ -2619,7 +3132,3 @@ unify_derived loc role    orig_ty1 orig_ty2
        | ty1 `tcEqType` ty2 = return ()
         -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)
        | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2
-
-maybeSym :: SwapFlag -> TcCoercion -> TcCoercion
-maybeSym IsSwapped  co = mkTcSymCo co
-maybeSym NotSwapped co = co
diff --git a/compiler/GHC/Tc/Solver/Flatten.hs b/compiler/GHC/Tc/Solver/Flatten.hs
index 22c92cff801339808d9a32cfc355b919ccbc95ae..c94dc21f2a6358d2028f6349cfad48a2ac96449f 100644
--- a/compiler/GHC/Tc/Solver/Flatten.hs
+++ b/compiler/GHC/Tc/Solver/Flatten.hs
@@ -5,18 +5,14 @@
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
 module GHC.Tc.Solver.Flatten(
-   FlattenMode(..),
    flatten, flattenKind, flattenArgsNom,
-   rewriteTyVar, flattenType,
-
-   unflattenWanteds
+   flattenType
  ) where
 
 #include "HsVersions.h"
 
 import GHC.Prelude
 
-import GHC.Tc.Types
 import GHC.Core.TyCo.Ppr ( pprTyVar )
 import GHC.Tc.Types.Constraint
 import GHC.Core.Predicate
@@ -29,468 +25,35 @@ import GHC.Core.Coercion
 import GHC.Types.Var
 import GHC.Types.Var.Set
 import GHC.Types.Var.Env
+import GHC.Driver.Session
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Tc.Solver.Monad as TcS
-import GHC.Types.Basic( SwapFlag(..) )
 
 import GHC.Utils.Misc
-import GHC.Data.Bag
+import GHC.Data.Maybe
 import Control.Monad
 import GHC.Utils.Monad ( zipWith3M )
-import Data.Foldable ( foldrM )
+import Data.List.NonEmpty ( NonEmpty(..) )
 
 import Control.Arrow ( first )
 
 {-
-Note [The flattening story]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* A CFunEqCan is either of form
-     [G] <F xis> : F xis ~ fsk   -- fsk is a FlatSkolTv
-     [W]       x : F xis ~ fmv   -- fmv is a FlatMetaTv
-  where
-     x is the witness variable
-     xis are function-free
-     fsk/fmv is a flatten skolem;
-        it is always untouchable (level 0)
-
-* CFunEqCans can have any flavour: [G], [W], [WD] or [D]
-
-* KEY INSIGHTS:
-
-   - A given flatten-skolem, fsk, is known a-priori to be equal to
-     F xis (the LHS), with <F xis> evidence.  The fsk is still a
-     unification variable, but it is "owned" by its CFunEqCan, and
-     is filled in (unflattened) only by unflattenGivens.
-
-   - A unification flatten-skolem, fmv, stands for the as-yet-unknown
-     type to which (F xis) will eventually reduce.  It is filled in
-
-
-   - All fsk/fmv variables are "untouchable".  To make it simple to test,
-     we simply give them TcLevel=0.  This means that in a CTyVarEq, say,
-       fmv ~ Int
-     we NEVER unify fmv.
-
-   - A unification flatten-skolem, fmv, ONLY gets unified when either
-       a) The CFunEqCan takes a step, using an axiom
-       b) By unflattenWanteds
-    They are never unified in any other form of equality.
-    For example [W] ffmv ~ Int  is stuck; it does not unify with fmv.
-
-* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan.
-  That would destroy the invariant about the shape of a CFunEqCan,
-  and it would risk wanted/wanted interactions. The only way we
-  learn information about fsk is when the CFunEqCan takes a step.
-
-  However we *do* substitute in the LHS of a CFunEqCan (else it
-  would never get to fire!)
-
-* Unflattening:
-   - We unflatten Givens when leaving their scope (see unflattenGivens)
-   - We unflatten Wanteds at the end of each attempt to simplify the
-     wanteds; see unflattenWanteds, called from solveSimpleWanteds.
-
-* Ownership of fsk/fmv.  Each canonical [G], [W], or [WD]
-       CFunEqCan x : F xis ~ fsk/fmv
-  "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv.
-  Why? We make a fresh fsk/fmv when the constraint is born;
-  and we never rewrite the RHS of a CFunEqCan.
-
-  In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W],
-  but does not "own" it.  If we reduce a [D] F Int ~ fmv, where
-  say type instance F Int = ty, then we don't discharge fmv := ty.
-  Rather we simply generate [D] fmv ~ ty (in GHC.Tc.Solver.Interact.reduce_top_fun_eq,
-  and dischargeFmv)
-
-* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2
-                       then xis1 /= xis2
-  i.e. at most one CFunEqCan with a particular LHS
-
-* Flattening a type (F xis):
-    - If we are flattening in a Wanted/Derived constraint
-      then create new [W] x : F xis ~ fmv
-      else create new [G] x : F xis ~ fsk
-      with fresh evidence variable x and flatten-skolem fsk/fmv
-
-    - Add it to the work list
-
-    - Replace (F xis) with fsk/fmv in the type you are flattening
-
-    - You can also add the CFunEqCan to the "flat cache", which
-      simply keeps track of all the function applications you
-      have flattened.
-
-    - If (F xis) is in the cache already, just
-      use its fsk/fmv and evidence x, and emit nothing.
-
-    - No need to substitute in the flat-cache. It's not the end
-      of the world if we start with, say (F alpha ~ fmv1) and
-      (F Int ~ fmv2) and then find alpha := Int.  Athat will
-      simply give rise to fmv1 := fmv2 via [Interacting rule] below
-
-* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv
-    - Flatten xis (to substitute any tyvars; there are already no functions)
-                  cos :: xis ~ flat_xis
-    - New wanted  x2 :: F flat_xis ~ fsk/fmv
-    - Add new wanted to flat cache
-    - Discharge x = F cos ; x2
-
-* [Interacting rule]
-    (inert)     [W] x1 : F tys ~ fmv1
-    (work item) [W] x2 : F tys ~ fmv2
-  Just solve one from the other:
-    x2 := x1
-    fmv2 := fmv1
-  This just unites the two fsks into one.
-  Always solve given from wanted if poss.
-
-* For top-level reductions, see Note [Top-level reductions for type functions]
-  in GHC.Tc.Solver.Interact
-
-
-Why given-fsks, alone, doesn't work
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Could we get away with only flatten meta-tyvars, with no flatten-skolems? No.
-
-  [W] w : alpha ~ [F alpha Int]
-
----> flatten
-  w = ...w'...
-  [W] w' : alpha ~ [fsk]
-  [G] <F alpha Int> : F alpha Int ~ fsk
-
---> unify (no occurs check)
-  alpha := [fsk]
-
-But since fsk = F alpha Int, this is really an occurs check error.  If
-that is all we know about alpha, we will succeed in constraint
-solving, producing a program with an infinite type.
-
-Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk)
-using axiom, zonking would not see it, so (x::alpha) sitting in the
-tree will get zonked to an infinite type.  (Zonking always only does
-refl stuff.)
-
-Why flatten-meta-vars, alone doesn't work
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Look at Simple13, with unification-fmvs only
-
-  [G] g : a ~ [F a]
-
----> Flatten given
-  g' = g;[x]
-  [G] g'  : a ~ [fmv]
-  [W] x : F a ~ fmv
-
---> subst a in x
-  g' = g;[x]
-  x = F g' ; x2
-  [W] x2 : F [fmv] ~ fmv
-
-And now we have an evidence cycle between g' and x!
-
-If we used a given instead (ie current story)
-
-  [G] g : a ~ [F a]
-
----> Flatten given
-  g' = g;[x]
-  [G] g'  : a ~ [fsk]
-  [G] <F a> : F a ~ fsk
-
----> Substitute for a
-  [G] g'  : a ~ [fsk]
-  [G] F (sym g'); <F a> : F [fsk] ~ fsk
-
-
-Why is it right to treat fmv's differently to ordinary unification vars?
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  f :: forall a. a -> a -> Bool
-  g :: F Int -> F Int -> Bool
-
-Consider
-  f (x:Int) (y:Bool)
-This gives alpha~Int, alpha~Bool.  There is an inconsistency,
-but really only one error.  SherLoc may tell you which location
-is most likely, based on other occurrences of alpha.
-
-Consider
-  g (x:Int) (y:Bool)
-Here we get (F Int ~ Int, F Int ~ Bool), which flattens to
-  (fmv ~ Int, fmv ~ Bool)
-But there are really TWO separate errors.
-
-  ** We must not complain about Int~Bool. **
-
-Moreover these two errors could arise in entirely unrelated parts of
-the code.  (In the alpha case, there must be *some* connection (eg
-v:alpha in common envt).)
-
-Note [Unflattening can force the solver to iterate]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Look at #10340:
-   type family Any :: *   -- No instances
-   get :: MonadState s m => m s
-   instance MonadState s (State s) where ...
-
-   foo :: State Any Any
-   foo = get
-
-For 'foo' we instantiate 'get' at types mm ss
-   [WD] MonadState ss mm, [WD] mm ss ~ State Any Any
-Flatten, and decompose
-   [WD] MonadState ss mm, [WD] Any ~ fmv
-   [WD] mm ~ State fmv, [WD] fmv ~ ss
-Unify mm := State fmv:
-   [WD] MonadState ss (State fmv)
-   [WD] Any ~ fmv, [WD] fmv ~ ss
-Now we are stuck; the instance does not match!!  So unflatten:
-   fmv := Any
-   ss := Any    (*)
-   [WD] MonadState Any (State Any)
-
-The unification (*) represents progress, so we must do a second
-round of solving; this time it succeeds. This is done by the 'go'
-loop in solveSimpleWanteds.
-
-This story does not feel right but it's the best I can do; and the
-iteration only happens in pretty obscure circumstances.
-
-
-************************************************************************
-*                                                                      *
-*                  Examples
-     Here is a long series of examples I had to work through
-*                                                                      *
-************************************************************************
-
-Simple20
-~~~~~~~~
-axiom F [a] = [F a]
-
- [G] F [a] ~ a
--->
- [G] fsk ~ a
- [G] [F a] ~ fsk  (nc)
--->
- [G] F a ~ fsk2
- [G] fsk ~ [fsk2]
- [G] fsk ~ a
--->
- [G] F a ~ fsk2
- [G] a ~ [fsk2]
- [G] fsk ~ a
-
-----------------------------------------
-indexed-types/should_compile/T44984
-
-  [W] H (F Bool) ~ H alpha
-  [W] alpha ~ F Bool
--->
-  F Bool  ~ fmv0
-  H fmv0  ~ fmv1
-  H alpha ~ fmv2
-
-  fmv1 ~ fmv2
-  fmv0 ~ alpha
-
-flatten
-~~~~~~~
-  fmv0  := F Bool
-  fmv1  := H (F Bool)
-  fmv2  := H alpha
-  alpha := F Bool
-plus
-  fmv1 ~ fmv2
-
-But these two are equal under the above assumptions.
-Solve by Refl.
-
-
---- under plan B, namely solve fmv1:=fmv2 eagerly ---
-  [W] H (F Bool) ~ H alpha
-  [W] alpha ~ F Bool
--->
-  F Bool  ~ fmv0
-  H fmv0  ~ fmv1
-  H alpha ~ fmv2
-
-  fmv1 ~ fmv2
-  fmv0 ~ alpha
--->
-  F Bool  ~ fmv0
-  H fmv0  ~ fmv1
-  H alpha ~ fmv2    fmv2 := fmv1
-
-  fmv0 ~ alpha
-
-flatten
-  fmv0 := F Bool
-  fmv1 := H fmv0 = H (F Bool)
-  retain   H alpha ~ fmv2
-    because fmv2 has been filled
-  alpha := F Bool
-
-
-----------------------------
-indexed-types/should_failt/T4179
-
-after solving
-  [W] fmv_1 ~ fmv_2
-  [W] A3 (FCon x)           ~ fmv_1    (CFunEqCan)
-  [W] A3 (x (aoa -> fmv_2)) ~ fmv_2    (CFunEqCan)
-
-----------------------------------------
-indexed-types/should_fail/T7729a
-
-a)  [W]   BasePrimMonad (Rand m) ~ m1
-b)  [W]   tt m1 ~ BasePrimMonad (Rand m)
-
---->  process (b) first
-    BasePrimMonad (Ramd m) ~ fmv_atH
-    fmv_atH ~ tt m1
-
---->  now process (a)
-    m1 ~ s_atH ~ tt m1    -- An obscure occurs check
-
-
-----------------------------------------
-typecheck/TcTypeNatSimple
-
-Original constraint
-  [W] x + y ~ x + alpha  (non-canonical)
-==>
-  [W] x + y     ~ fmv1   (CFunEqCan)
-  [W] x + alpha ~ fmv2   (CFuneqCan)
-  [W] fmv1 ~ fmv2        (CTyEqCan)
-
-(sigh)
-
-----------------------------------------
-indexed-types/should_fail/GADTwrong1
-
-  [G] Const a ~ ()
-==> flatten
-  [G] fsk ~ ()
-  work item: Const a ~ fsk
-==> fire top rule
-  [G] fsk ~ ()
-  work item fsk ~ ()
-
-Surely the work item should rewrite to () ~ ()?  Well, maybe not;
-it'a very special case.  More generally, our givens look like
-F a ~ Int, where (F a) is not reducible.
-
-
-----------------------------------------
-indexed_types/should_fail/T8227:
-
-Why using a different can-rewrite rule in CFunEqCan heads
-does not work.
-
-Assuming NOT rewriting wanteds with wanteds
-
-   Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk
-          [W] fmv_aBk ~ fsk_aBh
-
-          [G] Scalar fsk_aBg ~ fsk_aBh
-          [G] V a ~ f_aBg
-
-   Worklist includes  [W] Scalar fmv_aBi ~ fmv_aBk
-   fmv_aBi, fmv_aBk are flatten unification variables
-
-   Work item: [W] V fsk_aBh ~ fmv_aBi
-
-Note that the inert wanteds are cyclic, because we do not rewrite
-wanteds with wanteds.
-
-
-Then we go into a loop when normalise the work-item, because we
-use rewriteOrSame on the argument of V.
-
-Conclusion: Don't make canRewrite context specific; instead use
-[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable.
-
-
-----------------------------------------
-
-Here is a somewhat similar case:
-
-   type family G a :: *
-
-   blah :: (G a ~ Bool, Eq (G a)) => a -> a
-   blah = error "urk"
-
-   foo x = blah x
-
-For foo we get
-   [W] Eq (G a), G a ~ Bool
-Flattening
-   [W] G a ~ fmv, Eq fmv, fmv ~ Bool
-We can't simplify away the Eq Bool unless we substitute for fmv.
-Maybe that doesn't matter: we would still be left with unsolved
-G a ~ Bool.
-
---------------------------
-#9318 has a very simple program leading to
-
-  [W] F Int ~ Int
-  [W] F Int ~ Bool
-
-We don't want to get "Error Int~Bool".  But if fmv's can rewrite
-wanteds, we will
-
-  [W] fmv ~ Int
-  [W] fmv ~ Bool
---->
-  [W] Int ~ Bool
-
-
 ************************************************************************
 *                                                                      *
 *                FlattenEnv & FlatM
 *             The flattening environment & monad
 *                                                                      *
 ************************************************************************
-
 -}
 
-type FlatWorkListRef = TcRef [Ct]  -- See Note [The flattening work list]
-
 data FlattenEnv
-  = FE { fe_mode    :: !FlattenMode
-       , fe_loc     :: CtLoc              -- See Note [Flattener CtLoc]
-                      -- unbanged because it's bogus in rewriteTyVar
+  = FE { fe_loc     :: !CtLoc             -- See Note [Flattener CtLoc]
        , fe_flavour :: !CtFlavour
        , fe_eq_rel  :: !EqRel             -- See Note [Flattener EqRels]
-       , fe_work    :: !FlatWorkListRef } -- See Note [The flattening work list]
-
-data FlattenMode  -- Postcondition for all three: inert wrt the type substitution
-  = FM_FlattenAll          -- Postcondition: function-free
-  | FM_SubstOnly           -- See Note [Flattening under a forall]
-
---  | FM_Avoid TcTyVar Bool  -- See Note [Lazy flattening]
---                           -- Postcondition:
---                           --  * tyvar is only mentioned in result under a rigid path
---                           --    e.g.   [a] is ok, but F a won't happen
---                           --  * If flat_top is True, top level is not a function application
---                           --   (but under type constructors is ok e.g. [F a])
-
-instance Outputable FlattenMode where
-  ppr FM_FlattenAll = text "FM_FlattenAll"
-  ppr FM_SubstOnly  = text "FM_SubstOnly"
-
-eqFlattenMode :: FlattenMode -> FlattenMode -> Bool
-eqFlattenMode FM_FlattenAll FM_FlattenAll = True
-eqFlattenMode FM_SubstOnly  FM_SubstOnly  = True
---  FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2
-eqFlattenMode _  _ = False
-
--- | The 'FlatM' monad is a wrapper around 'TcS' with the following
--- extra capabilities: (1) it offers access to a 'FlattenEnv';
--- and (2) it maintains the flattening worklist.
--- See Note [The flattening work list].
+       }
+
+-- | The 'FlatM' monad is a wrapper around 'TcS' with a 'FlattenEnv'
 newtype FlatM a
   = FlatM { runFlatM :: FlattenEnv -> TcS a }
   deriving (Functor)
@@ -504,45 +67,27 @@ instance Applicative FlatM where
   pure x = FlatM $ const (pure x)
   (<*>) = ap
 
+instance HasDynFlags FlatM where
+  getDynFlags = liftTcS getDynFlags
+
 liftTcS :: TcS a -> FlatM a
 liftTcS thing_inside
   = FlatM $ const thing_inside
 
-emitFlatWork :: Ct -> FlatM ()
--- See Note [The flattening work list]
-emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :)
-
 -- convenient wrapper when you have a CtEvidence describing
 -- the flattening operation
-runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a
-runFlattenCtEv mode ev
-  = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)
-
--- Run thing_inside (which does flattening), and put all
--- the work it generates onto the main work list
--- See Note [The flattening work list]
-runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a
-runFlatten mode loc flav eq_rel thing_inside
-  = do { flat_ref <- newTcRef []
-       ; let fmode = FE { fe_mode = mode
-                        , fe_loc  = bumpCtLocDepth loc
-                            -- See Note [Flatten when discharging CFunEqCan]
-                        , fe_flavour = flav
-                        , fe_eq_rel = eq_rel
-                        , fe_work = flat_ref }
-       ; res <- runFlatM thing_inside fmode
-       ; new_flats <- readTcRef flat_ref
-       ; updWorkListTcS (add_flats new_flats)
-       ; return res }
+runFlattenCtEv :: CtEvidence -> FlatM a -> TcS a
+runFlattenCtEv ev
+  = runFlatten (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)
+
+-- Run thing_inside (which does the flattening)
+runFlatten :: CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a
+runFlatten loc flav eq_rel thing_inside
+  = runFlatM thing_inside fmode
   where
-    add_flats new_flats wl
-      = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) }
-
-    add_funeqs []     wl = wl
-    add_funeqs (f:fs) wl = add_funeqs fs (f:wl)
-      -- add_funeqs fs ws = reverse fs ++ ws
-      -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4]
-      --        = [f3,f2,f1,w1,w2,w3,w4]
+    fmode = FE { fe_loc  = loc
+               , fe_flavour = flav
+               , fe_eq_rel = eq_rel }
 
 traceFlat :: String -> SDoc -> FlatM ()
 traceFlat herald doc = liftTcS $ traceTcS herald doc
@@ -567,9 +112,6 @@ getFlavourRole
        ; eq_rel <- getEqRel
        ; return (flavour, eq_rel) }
 
-getMode :: FlatM FlattenMode
-getMode = getFlatEnvField fe_mode
-
 getLoc :: FlatM CtLoc
 getLoc = getFlatEnvField fe_loc
 
@@ -585,14 +127,7 @@ setEqRel new_eq_rel thing_inside
     if new_eq_rel == fe_eq_rel env
     then runFlatM thing_inside env
     else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel })
-
--- | Change the 'FlattenMode' in a 'FlattenEnv'.
-setMode :: FlattenMode -> FlatM a -> FlatM a
-setMode new_mode thing_inside
-  = FlatM $ \env ->
-    if new_mode `eqFlattenMode` fe_mode env
-    then runFlatM thing_inside env
-    else runFlatM thing_inside (env { fe_mode = new_mode })
+{-# INLINE setEqRel #-}
 
 -- | Make sure that flattening actually produces a coercion (in other
 -- words, make sure our flavour is not Derived)
@@ -616,55 +151,6 @@ bumpDepth (FlatM thing_inside)
       ; thing_inside env' }
 
 {-
-Note [The flattening work list]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The "flattening work list", held in the fe_work field of FlattenEnv,
-is a list of CFunEqCans generated during flattening.  The key idea
-is this.  Consider flattening (Eq (F (G Int) (H Bool)):
-  * The flattener recursively calls itself on sub-terms before building
-    the main term, so it will encounter the terms in order
-              G Int
-              H Bool
-              F (G Int) (H Bool)
-    flattening to sub-goals
-              w1: G Int ~ fuv0
-              w2: H Bool ~ fuv1
-              w3: F fuv0 fuv1 ~ fuv2
-
-  * Processing w3 first is BAD, because we can't reduce i t,so it'll
-    get put into the inert set, and later kicked out when w1, w2 are
-    solved.  In #9872 this led to inert sets containing hundreds
-    of suspended calls.
-
-  * So we want to process w1, w2 first.
-
-  * So you might think that we should just use a FIFO deque for the work-list,
-    so that putting adding goals in order w1,w2,w3 would mean we processed
-    w1 first.
-
-  * BUT suppose we have 'type instance G Int = H Char'.  Then processing
-    w1 leads to a new goal
-                w4: H Char ~ fuv0
-    We do NOT want to put that on the far end of a deque!  Instead we want
-    to put it at the *front* of the work-list so that we continue to work
-    on it.
-
-So the work-list structure is this:
-
-  * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on
-    top (extendWorkListFunEq), and take new work from the top
-    (selectWorkItem).
-
-  * When flattening, emitFlatWork pushes new flattening goals (like
-    w1,w2,w3) onto the flattening work list, fe_work, another
-    push-down stack.
-
-  * When we finish flattening, we *reverse* the fe_work stack
-    onto the wl_funeqs stack (which brings w1 to the top).
-
-The function runFlatten initialises the fe_work stack, and reverses
-it onto wl_fun_eqs at the end.
-
 Note [Flattener EqRels]
 ~~~~~~~~~~~~~~~~~~~~~~~
 When flattening, we need to know which equality relation -- nominal
@@ -693,32 +179,6 @@ will be essentially impossible. So, the official recommendation if a
 stack limit is hit is to disable the check entirely. Otherwise, there
 will be baffling, unpredictable errors.
 
-Note [Lazy flattening]
-~~~~~~~~~~~~~~~~~~~~~~
-The idea of FM_Avoid mode is to flatten less aggressively.  If we have
-       a ~ [F Int]
-there seems to be no great merit in lifting out (F Int).  But if it was
-       a ~ [G a Int]
-then we *do* want to lift it out, in case (G a Int) reduces to Bool, say,
-which gets rid of the occurs-check problem.  (For the flat_top Bool, see
-comments above and at call sites.)
-
-HOWEVER, the lazy flattening actually seems to make type inference go
-*slower*, not faster.  perf/compiler/T3064 is a case in point; it gets
-*dramatically* worse with FM_Avoid.  I think it may be because
-floating the types out means we normalise them, and that often makes
-them smaller and perhaps allows more re-use of previously solved
-goals.  But to be honest I'm not absolutely certain, so I am leaving
-FM_Avoid in the code base.  What I'm removing is the unique place
-where it is *used*, namely in GHC.Tc.Solver.Canonical.canEqTyVar.
-
-See also Note [Conservative unification check] in GHC.Tc.Utils.Unify, which gives
-other examples where lazy flattening caused problems.
-
-Bottom line: FM_Avoid is unused for now (Nov 14).
-Note: T5321Fun got faster when I disabled FM_Avoid
-      T5837 did too, but it's pathological anyway
-
 Note [Phantoms in the flattener]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we have
@@ -730,8 +190,8 @@ is really irrelevant -- it will be ignored when solving for representational
 equality later on. So, we omit flattening `ty` entirely. This may
 violate the expectation of "xi"s for a bit, but the canonicaliser will
 soon throw out the phantoms when decomposing a TyConApp. (Or, the
-canonicaliser will emit an insoluble, in which case the unflattened version
-yields a better error message anyway.)
+canonicaliser will emit an insoluble, in which case we get
+a better error message anyway.)
 
 Note [No derived kind equalities]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -751,52 +211,19 @@ changes the flavour from Derived just for this purpose.
 *  flattening work gets put into the work list                         *
 *                                                                      *
 *********************************************************************
-
-Note [rewriteTyVar]
-~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have an injective function F and
-  inert_funeqs:   F t1 ~ fsk1
-                  F t2 ~ fsk2
-  inert_eqs:      fsk1 ~ [a]
-                  a ~ Int
-                  fsk2 ~ [Int]
-
-We never rewrite the RHS (cc_fsk) of a CFunEqCan. But we /do/ want to get the
-[D] t1 ~ t2 from the injectiveness of F. So we flatten cc_fsk of CFunEqCans
-when trying to find derived equalities arising from injectivity.
 -}
 
 -- | See Note [Flattening].
 -- If (xi, co) <- flatten mode ev ty, then co :: xi ~r ty
--- where r is the role in @ev@. If @mode@ is 'FM_FlattenAll',
--- then 'xi' is almost function-free (Note [Almost function-free]
--- in "GHC.Tc.Types").
-flatten :: FlattenMode -> CtEvidence -> TcType
+-- where r is the role in @ev@.
+flatten :: CtEvidence -> TcType
         -> TcS (Xi, TcCoercion)
-flatten mode ev ty
-  = do { traceTcS "flatten {" (ppr mode <+> ppr ty)
-       ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty)
+flatten ev ty
+  = do { traceTcS "flatten {" (ppr ty)
+       ; (ty', co) <- runFlattenCtEv ev (flatten_one ty)
        ; traceTcS "flatten }" (ppr ty')
        ; return (ty', co) }
 
--- Apply the inert set as an *inert generalised substitution* to
--- a variable, zonking along the way.
--- See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad.
--- Equivalently, this flattens the variable with respect to NomEq
--- in a Derived constraint. (Why Derived? Because Derived allows the
--- most about of rewriting.) Returns no coercion, because we're
--- using Derived constraints.
--- See Note [rewriteTyVar]
-rewriteTyVar :: TcTyVar -> TcS TcType
-rewriteTyVar tv
-  = do { traceTcS "rewriteTyVar {" (ppr tv)
-       ; (ty, _) <- runFlatten FM_SubstOnly fake_loc Derived NomEq $
-                    flattenTyVar tv
-       ; traceTcS "rewriteTyVar }" (ppr ty)
-       ; return ty }
-  where
-    fake_loc = pprPanic "rewriteTyVar used a CtLoc" (ppr tv)
-
 -- specialized to flattening kinds: never Derived, always Nominal
 -- See Note [No derived kind equalities]
 -- See Note [Flattening]
@@ -806,28 +233,29 @@ flattenKind loc flav ty
        ; let flav' = case flav of
                        Derived -> Wanted WDeriv  -- the WDeriv/WOnly choice matters not
                        _       -> flav
-       ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty)
+       ; (ty', co) <- runFlatten loc flav' NomEq (flatten_one ty)
        ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic
        ; return (ty', co) }
 
 -- See Note [Flattening]
-flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN)
+flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion])
 -- Externally-callable, hence runFlatten
 -- Flatten a vector of types all at once; in fact they are
 -- always the arguments of type family or class, so
 --      ctEvFlavour ev = Nominal
 -- and we want to flatten all at nominal role
 -- The kind passed in is the kind of the type family or class, call it T
--- The last coercion returned has type (tcTypeKind(T xis) ~N tcTypeKind(T tys))
+-- The kind of T args must be constant (i.e. not depend on the args)
 --
 -- For Derived constraints the returned coercion may be undefined
 -- because flattening may use a Derived equality ([D] a ~ ty)
 flattenArgsNom ev tc tys
   = do { traceTcS "flatten_args {" (vcat (map ppr tys))
        ; (tys', cos, kind_co)
-           <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys)
+           <- runFlattenCtEv ev (flatten_args_tc tc Nothing tys)
+       ; MASSERT( isReflMCo kind_co )
        ; traceTcS "flatten }" (vcat (map ppr tys'))
-       ; return (tys', cos, kind_co) }
+       ; return (tys', cos) }
 
 -- | Flatten a type w.r.t. nominal equality. This is useful to rewrite
 -- a type w.r.t. any givens. It does not do type-family reduction. This
@@ -835,8 +263,7 @@ flattenArgsNom ev tc tys
 -- only givens.
 flattenType :: CtLoc -> TcType -> TcS TcType
 flattenType loc ty
-          -- More info about FM_SubstOnly in Note [Holes] in GHC.Tc.Types.Constraint
-  = do { (xi, _) <- runFlatten FM_SubstOnly loc Given NomEq $
+  = do { (xi, _) <- runFlatten loc Given NomEq $
                     flatten_one ty
                      -- use Given flavor so that it is rewritten
                      -- only w.r.t. Givens, never Wanteds/Deriveds
@@ -854,35 +281,31 @@ flattenType loc ty
 ~~~~~~~~~~~~~~~~~~~~
   flatten ty  ==>   (xi, co)
     where
-      xi has no type functions, unless they appear under ForAlls
+      xi has no reducible type functions
          has no skolems that are mapped in the inert set
          has no filled-in metavariables
       co :: xi ~ ty
 
 Key invariants:
-  (F0) co :: xi ~ zonk(ty)
+  (F0) co :: xi ~ zonk(ty')    where zonk(ty') ~ zonk(ty)
   (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind
   (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))
 
-Note that it is flatten's job to flatten *every type function it sees*.
-flatten is only called on *arguments* to type functions, by canEqGiven.
+Note that it is flatten's job to try to reduce *every type function it sees*.
 
 Flattening also:
   * zonks, removing any metavariables, and
   * applies the substitution embodied in the inert set
 
-The result of flattening is *almost function-free*. See
-Note [Almost function-free] in GHC.Tc.Utils.
-
 Because flattening zonks and the returned coercion ("co" above) is also
 zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead,
 we can rely on this fact:
 
-  (F0) co :: xi ~ zonk(ty)
+  (F0) co :: xi ~ zonk(ty'), where zonk(ty') ~ zonk(ty)
 
 Note that the left-hand type of co is *always* precisely xi. The right-hand
 type may or may not be ty, however: if ty has unzonked filled-in metavariables,
-then the right-hand type of co will be the zonked version of ty.
+then the right-hand type of co will be the zonk-equal to ty.
 It is for this reason that we
 occasionally have to explicitly zonk, when (co :: xi ~ ty) is important
 even before we zonk the whole program. For example, see the FTRNotFollowed
@@ -890,7 +313,7 @@ case in flattenTyVar.
 
 Why have these invariants on flattening? Because we sometimes use tcTypeKind
 during canonicalisation, and we want this kind to be zonked (e.g., see
-GHC.Tc.Solver.Canonical.canEqTyVar).
+GHC.Tc.Solver.Canonical.canEqCanLHS).
 
 Flattening is always homogeneous. That is, the kind of the result of flattening is
 always the same as the kind of the input, modulo zonking. More formally:
@@ -903,26 +326,12 @@ Recall that in comments we use alpha[flat = ty] to represent a
 flattening skolem variable alpha which has been generated to stand in
 for ty.
 
------ Example of flattening a constraint: ------
-  flatten (List (F (G Int)))  ==>  (xi, cc)
-    where
-      xi  = List alpha
-      cc  = { G Int ~ beta[flat = G Int],
-              F beta ~ alpha[flat = F beta] }
-Here
-  * alpha and beta are 'flattening skolem variables'.
-  * All the constraints in cc are 'given', and all their coercion terms
-    are the identity.
-
-NB: Flattening Skolems only occur in canonical constraints, which
-are never zonked, so we don't need to worry about zonking doing
-accidental unflattening.
-
 Note that we prefer to leave type synonyms unexpanded when possible,
 so when the flattener encounters one, it first asks whether its
-transitive expansion contains any type function applications.  If so,
+transitive expansion contains any type function applications or is
+forgetful -- that is, omits one or more type variables in its RHS.  If so,
 it expands the synonym and proceeds; if not, it simply returns the
-unexpanded synonym.
+unexpanded synonym. See also Note [Flattening synonyms].
 
 Note [flatten_args performance]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -955,33 +364,34 @@ If we need to make this yet more performant, a possible way forward is to
 duplicate the flattener code for the nominal case, and make that case
 faster. This doesn't seem quite worth it, yet.
 
-Note [flatten_exact_fam_app_fully performance]
+Note [flatten_exact_fam_app performance]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The refactor of GRefl seems to cause performance trouble for T9872x:
-the allocation of flatten_exact_fam_app_fully_performance
-increased. See note [Generalized reflexive coercion] in
-GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the
-current state.
-
-The explicit pattern match in homogenise_result helps with T9872a, b, c.
-
-Still, it increases the expected allocation of T9872d by ~2%.
-
-TODO: a step-by-step replay of the refactor to analyze the performance.
-
+Once we've got a flat rhs, we extend the famapp-cache to record
+the result. Doing so can save lots of work when the same redex shows up more
+than once. Note that we record the link from the redex all the way to its
+*final* value, not just the single step reduction.
+
+If we can reduce the family application right away (the first call
+to try_to_reduce), we do *not* add to the cache. There are two possibilities
+here: 1) we just read the result from the cache, or 2) we used one type
+family instance. In either case, recording the result in the cache doesn't
+save much effort the next time around. And adding to the cache here is
+actually disastrous: it more than doubles the allocations for T9872a. So
+we skip adding to the cache here.
 -}
 
 {-# INLINE flatten_args_tc #-}
 flatten_args_tc
   :: TyCon         -- T
-  -> [Role]        -- Role r
+  -> Maybe [Role]  -- Nothing: ambient role is Nominal; all args are Nominal
+                   -- Otherwise: no assumptions; use roles provided
   -> [Type]        -- Arg types [t1,..,tn]
   -> FlatM ( [Xi]  -- List of flattened args [x1,..,xn]
                    -- 1-1 corresp with [t1,..,tn]
            , [Coercion]  -- List of arg coercions [co1,..,con]
                          -- 1-1 corresp with [t1,..,tn]
                          --    coi :: xi ~r ti
-           , CoercionN)  -- Result coercion, rco
+           , MCoercionN) -- Result coercion, rco
                          --    rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con))
 flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet
   -- NB: TyCon kinds are always closed
@@ -999,8 +409,9 @@ flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet
 flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are
                                      -- named.
              -> Kind -> TcTyCoVarSet -- function kind; kind's free vars
-             -> [Role] -> [Type]     -- these are in 1-to-1 correspondence
-             -> FlatM ([Xi], [Coercion], CoercionN)
+             -> Maybe [Role] -> [Type]    -- these are in 1-to-1 correspondence
+                                          -- Nothing: use all Nominal
+             -> FlatM ([Xi], [Coercion], MCoercionN)
 -- Coercions :: Xi ~ Type, at roles given
 -- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys)
 -- That is, the third coercion relates the kind of some function (whose kind is
@@ -1012,15 +423,12 @@ flatten_args orig_binders
              any_named_bndrs
              orig_inner_ki
              orig_fvs
-             orig_roles
+             orig_m_roles
              orig_tys
-  = if any_named_bndrs
-    then flatten_args_slow orig_binders
-                           orig_inner_ki
-                           orig_fvs
-                           orig_roles
-                           orig_tys
-    else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys
+  = case (orig_m_roles, any_named_bndrs) of
+      (Nothing, False) -> flatten_args_fast orig_tys
+      _ -> flatten_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys
+        where orig_roles = fromMaybe (repeat Nominal) orig_m_roles
 
 {-# INLINE flatten_args_fast #-}
 -- | fast path flatten_args, in which none of the binders are named and
@@ -1028,75 +436,30 @@ flatten_args orig_binders
 -- There are many bang patterns in here. It's been observed that they
 -- greatly improve performance of an optimized build.
 -- The T9872 test cases are good witnesses of this fact.
-flatten_args_fast :: [TyCoBinder]
-                  -> Kind
-                  -> [Role]
-                  -> [Type]
-                  -> FlatM ([Xi], [Coercion], CoercionN)
-flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys
-  = fmap finish (iterate orig_tys orig_roles orig_binders)
+flatten_args_fast :: [Type]
+                  -> FlatM ([Xi], [Coercion], MCoercionN)
+flatten_args_fast orig_tys
+  = fmap finish (iterate orig_tys)
   where
 
     iterate :: [Type]
-            -> [Role]
-            -> [TyCoBinder]
-            -> FlatM ([Xi], [Coercion], [TyCoBinder])
-    iterate (ty:tys) (role:roles) (_:binders) = do
-      (xi, co) <- go role ty
-      (xis, cos, binders) <- iterate tys roles binders
-      pure (xi : xis, co : cos, binders)
-    iterate [] _ binders = pure ([], [], binders)
-    iterate _ _ _ = pprPanic
-        "flatten_args wandered into deeper water than usual" (vcat [])
-           -- This debug information is commented out because leaving it in
-           -- causes a ~2% increase in allocations in T9872{a,c,d}.
-           {-
-             (vcat [ppr orig_binders,
-                    ppr orig_inner_ki,
-                    ppr (take 10 orig_roles), -- often infinite!
-                    ppr orig_tys])
-           -}
-
-    {-# INLINE go #-}
-    go :: Role
-       -> Type
-       -> FlatM (Xi, Coercion)
-    go role ty
-      = case role of
-          -- In the slow path we bind the Xi and Coercion from the recursive
-          -- call and then use it such
-          --
-          --   let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder)
-          --       casted_xi = xi `mkCastTy` kind_co
-          --       casted_co = xi |> kind_co ~r xi ; co
-          --
-          -- but this isn't necessary:
-          --   mkTcSymCo (Refl a b) = Refl a b,
-          --   mkCastTy x (Refl _ _) = x
-          --   mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co
-          --
-          -- Also, no need to check isAnonTyCoBinder or isNamedBinder, since
-          -- we've already established that they're all anonymous.
-          Nominal          -> setEqRel NomEq  $ flatten_one ty
-          Representational -> setEqRel ReprEq $ flatten_one ty
-          Phantom          -> -- See Note [Phantoms in the flattener]
-                              do { ty <- liftTcS $ zonkTcType ty
-                                 ; return (ty, mkReflCo Phantom ty) }
-
+            -> FlatM ([Xi], [Coercion])
+    iterate (ty:tys) = do
+      (xi, co)   <- flatten_one ty
+      (xis, cos) <- iterate tys
+      pure (xi : xis, co : cos)
+    iterate [] = pure ([], [])
 
     {-# INLINE finish #-}
-    finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN)
-    finish (xis, cos, binders) = (xis, cos, kind_co)
-      where
-        final_kind = mkPiTys binders orig_inner_ki
-        kind_co    = mkNomReflCo final_kind
+    finish :: ([Xi], [Coercion]) -> ([Xi], [Coercion], MCoercionN)
+    finish (xis, cos) = (xis, cos, MRefl)
 
 {-# INLINE flatten_args_slow #-}
 -- | Slow path, compared to flatten_args_fast, because this one must track
 -- a lifting context.
 flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet
                   -> [Role] -> [Type]
-                  -> FlatM ([Xi], [Coercion], CoercionN)
+                  -> FlatM ([Xi], [Coercion], MCoercionN)
 flatten_args_slow binders inner_ki fvs roles tys
 -- Arguments used dependently must be flattened with proper coercions, but
 -- we're not guaranteed to get a proper coercion when flattening with the
@@ -1143,6 +506,10 @@ flatten_one :: TcType -> FlatM (Xi, Coercion)
 -- Postcondition: Coercion :: Xi ~ TcType
 -- The role on the result coercion matches the EqRel in the FlattenEnv
 
+flatten_one ty
+  | Just ty' <- flattenView ty  -- See Note [Flattening synonyms]
+  = flatten_one ty'
+
 flatten_one xi@(LitTy {})
   = do { role <- getRole
        ; return (xi, mkReflCo role xi) }
@@ -1154,19 +521,7 @@ flatten_one (AppTy ty1 ty2)
   = flatten_app_tys ty1 [ty2]
 
 flatten_one (TyConApp tc tys)
-  -- Expand type synonyms that mention type families
-  -- on the RHS; see Note [Flattening synonyms]
-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
-  , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'
-  = do { mode <- getMode
-       ; case mode of
-           FM_FlattenAll | not (isFamFreeTyCon tc)
-                         -> flatten_one expanded_ty
-           _             -> flatten_ty_con_app tc tys }
-
-  -- Otherwise, it's a type function application, and we have to
-  -- flatten it away as well, and generate a new given equality constraint
-  -- between the application and a newly generated flattening skolem variable.
+  -- If it's a type family application, try to reduce it
   | isTypeFamilyTyCon tc
   = flatten_fam_app tc tys
 
@@ -1174,11 +529,6 @@ flatten_one (TyConApp tc tys)
   --     * data family application
   -- we just recursively flatten the arguments.
   | otherwise
--- FM_Avoid stuff commented out; see Note [Lazy flattening]
---  , let fmode' = case fmode of  -- Switch off the flat_top bit in FM_Avoid
---                   FE { fe_mode = FM_Avoid tv _ }
---                     -> fmode { fe_mode = FM_Avoid tv False }
---                   _ -> fmode
   = flatten_ty_con_app tc tys
 
 flatten_one ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })
@@ -1198,14 +548,12 @@ flatten_one ty@(ForAllTy {})
 -- applications inside the forall involve the bound type variables.
   = do { let (bndrs, rho) = tcSplitForAllTyVarBinders ty
              tvs           = binderVars bndrs
-       ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho
-                         -- Substitute only under a forall
-                         -- See Note [Flattening under a forall]
+       ; (rho', co) <- flatten_one rho
        ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) }
 
 flatten_one (CastTy ty g)
   = do { (xi, co) <- flatten_one ty
-       ; (g', _)   <- flatten_co g
+       ; (g', _)  <- flatten_co g
        ; role <- getRole
        ; return (mkCastTy xi g', castCoercionKind1 co role xi ty g') }
          -- It makes a /big/ difference to call castCoercionKind1 not
@@ -1279,7 +627,9 @@ flatten_app_ty_args fun_xi fun_co arg_tys
 flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
 flatten_ty_con_app tc tys
   = do { role <- getRole
-       ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys
+       ; let m_roles | Nominal <- role = Nothing
+                     | otherwise       = Just $ tyConRolesX role tc
+       ; (xis, cos, kind_co) <- flatten_args_tc tc m_roles tys
        ; let tyconapp_xi = mkTyConApp tc xis
              tyconapp_co = mkTyConAppCo role tc cos
        ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) }
@@ -1288,15 +638,12 @@ flatten_ty_con_app tc tys
 homogenise_result :: Xi              -- a flattened type
                   -> Coercion        -- :: xi ~r original ty
                   -> Role            -- r
-                  -> CoercionN       -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty)
+                  -> MCoercionN      -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty)
                   -> (Xi, Coercion)  -- (xi |> kind_co, (xi |> kind_co)
                                      --   ~r original ty)
-homogenise_result xi co r kind_co
-  -- the explicit pattern match here improves the performance of T9872a, b, c by
-  -- ~2%
-  | isGReflCo kind_co = (xi `mkCastTy` kind_co, co)
-  | otherwise         = (xi `mkCastTy` kind_co
-                        , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co)
+homogenise_result xi co _ MRefl = (xi, co)
+homogenise_result xi co r mco@(MCo kind_co)
+  = (xi `mkCastTy` kind_co, (mkSymCo $ GRefl r xi mco) `mkTransCo` co)
 {-# INLINE homogenise_result #-}
 
 -- Flatten a vector (list of arguments).
@@ -1304,7 +651,7 @@ flatten_vector :: Kind   -- of the function being applied to these arguments
                -> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the
                          -- args have?
                -> [Type] -- the args to flatten
-               -> FlatM ([Xi], [Coercion], CoercionN)
+               -> FlatM ([Xi], [Coercion], MCoercionN)
 flatten_vector ki roles tys
   = do { eq_rel <- getEqRel
        ; case eq_rel of
@@ -1312,17 +659,17 @@ flatten_vector ki roles tys
                                   any_named_bndrs
                                   inner_ki
                                   fvs
-                                  (repeat Nominal)
+                                  Nothing
                                   tys
            ReprEq -> flatten_args bndrs
                                   any_named_bndrs
                                   inner_ki
                                   fvs
-                                  roles
+                                  (Just roles)
                                   tys
        }
   where
-    (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki
+    (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki  -- "RAE" fix
     fvs                                = tyCoVarsOfType ki
 {-# INLINE flatten_vector #-}
 
@@ -1333,251 +680,215 @@ Not expanding synonyms aggressively improves error messages, and
 keeps types smaller. But we need to take care.
 
 Suppose
-   type T a = a -> a
-and we want to flatten the type (T (F a)).  Then we can safely flatten
-the (F a) to a skolem, and return (T fsk).  We don't need to expand the
-synonym.  This works because TcTyConAppCo can deal with synonyms
-(unlike TyConAppCo), see Note [TcCoercions] in GHC.Tc.Types.Evidence.
+   type Syn a = Int
+   type instance F Bool = Syn (F Bool)
+   [G] F Bool ~ Syn (F Bool)
 
-But (#8979) for
-   type T a = (F a, a)    where F is a type function
-we must expand the synonym in (say) T Int, to expose the type function
-to the flattener.
+If we don't expand the synonym, we'll get a spurious occurs-check
+failure. This is normally what occCheckExpand takes care of, but
+the LHS is a type family application, and occCheckExpand (already
+complex enough as it is) does not know how to expand to avoid
+a type family application.
 
+In addition, expanding the forgetful synonym like this
+will generally yield a *smaller* type. To wit, if we spot
+S ( ... F tys ... ), where S is forgetful, we don't want to bother
+doing hard work simplifying (F tys). We thus expand forgetful
+synonyms, but not others.
 
-Note [Flattening under a forall]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Under a forall, we
-  (a) MUST apply the inert substitution
-  (b) MUST NOT flatten type family applications
-Hence FMSubstOnly.
+isForgetfulSynTyCon returns True more often than it needs to, so
+we err on the side of more expansion.
 
-For (a) consider   c ~ a, a ~ T (forall b. (b, [c]))
-If we don't apply the c~a substitution to the second constraint
-we won't see the occurs-check error.
-
-For (b) consider  (a ~ forall b. F a b), we don't want to flatten
-to     (a ~ forall b.fsk, F a b ~ fsk)
-because now the 'b' has escaped its scope.  We'd have to flatten to
-       (a ~ forall b. fsk b, forall b. F a b ~ fsk b)
-and we have not begun to think about how to make that work!
+We also, of course, must expand type synonyms that mention type families,
+so those families can get reduced.
 
 ************************************************************************
 *                                                                      *
              Flattening a type-family application
 *                                                                      *
 ************************************************************************
+
+Note [How to normalise a family application]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given an exactly saturated family application, how should we normalise it?
+This Note spells out the algorithm and its reasoning.
+
+STEP 1. Try the famapp-cache. If we get a cache hit, jump to FINISH.
+
+STEP 2. Try top-level instances. Note that we haven't simplified the arguments
+  yet. Example:
+    type instance F (Maybe a) = Int
+    target: F (Maybe (G Bool))
+  Instead of first trying to simplify (G Bool), we use the instance first. This
+  avoids the work of simplifying G Bool.
+
+  If an instance is found, jump to FINISH.
+
+STEP 3. Flatten all arguments. This might expose more information so that we
+  can use a top-level instance.
+
+  Continue to the next step.
+
+STEP 4. Try the inerts. Note that we try the inerts *after* flattening the
+  arguments, because the inerts will have flattened LHSs.
+
+  If an inert is found, jump to FINISH.
+
+STEP 5. Try the famapp-cache again. Now that we've revealed more information
+  in the arguments, the cache might be helpful.
+
+  If we get a cache hit, jump to FINISH.
+
+STEP 6. Try top-level instances, which might trigger now that we know more
+  about the argumnents.
+
+  If an instance is found, jump to FINISH.
+
+STEP 7. No progress to be made. Return what we have. (Do not do FINISH.)
+
+FINISH 1. We've made a reduction, but the new type may still have more
+  work to do. So flatten the new type.
+
+FINISH 2. Add the result to the famapp-cache, connecting the type we started
+  with to the one we ended with.
+
+Because STEP 1/2 and STEP 5/6 happen the same way, they are abstracted into
+try_to_reduce.
+
+FINISH is naturally implemented in `finish`. But, Note [flatten_exact_fam_app performance]
+tells us that we should not add to the famapp-cache after STEP 1/2. So `finish`
+is inlined in that case, and only FINISH 1 is performed.
+
 -}
 
 flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
   --   flatten_fam_app            can be over-saturated
-  --   flatten_exact_fam_app       is exactly saturated
-  --   flatten_exact_fam_app_fully lifts out the application to top level
+  --   flatten_exact_fam_app      lifts out the application to top level
   -- Postcondition: Coercion :: Xi ~ F tys
 flatten_fam_app tc tys  -- Can be over-saturated
     = ASSERT2( tys `lengthAtLeast` tyConArity tc
              , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)
 
-      do { mode <- getMode
-         ; case mode of
-             { FM_SubstOnly  -> flatten_ty_con_app tc tys
-             ; FM_FlattenAll ->
-
                  -- Type functions are saturated
                  -- The type function might be *over* saturated
                  -- in which case the remaining arguments should
                  -- be dealt with by AppTys
       do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys
-         ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1
+         ; (xi1, co1) <- flatten_exact_fam_app tc tys1
                -- co1 :: xi1 ~ F tys1
 
-         ; flatten_app_ty_args xi1 co1 tys_rest } } }
+         ; flatten_app_ty_args xi1 co1 tys_rest }
 
 -- the [TcType] exactly saturate the TyCon
--- See note [flatten_exact_fam_app_fully performance]
-flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
-flatten_exact_fam_app_fully tc tys
-  -- See Note [Reduce type family applications eagerly]
-     -- the following tcTypeKind should never be evaluated, as it's just used in
-     -- casting, and casts by refl are dropped
-  = do { mOut <- try_to_reduce_nocache tc tys
-       ; case mOut of
-           Just out -> pure out
-           Nothing -> do
-               { -- First, flatten the arguments
-               ; (xis, cos, kind_co)
-                   <- setEqRel NomEq $  -- just do this once, instead of for
-                                        -- each arg
-                      flatten_args_tc tc (repeat Nominal) tys
-                      -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys)
-               ; eq_rel   <- getEqRel
-               ; cur_flav <- getFlavour
-               ; let role   = eqRelRole eq_rel
-                     ret_co = mkTyConAppCo role tc cos
-                      -- ret_co :: F xis ~ F tys; might be heterogeneous
-
-                -- Now, look in the cache
-               ; mb_ct <- liftTcS $ lookupFlatCache tc xis
-               ; case mb_ct of
-                   Just (co, rhs_ty, flav)  -- co :: F xis ~ fsk
-                        -- flav is [G] or [WD]
-                        -- See Note [Type family equations] in GHC.Tc.Solver.Monad
-                     | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav
-                     ->  -- Usable hit in the flat-cache
-                        do { traceFlat "flatten/flat-cache hit" $
-                               (ppr tc <+> ppr xis $$ ppr rhs_ty)
-                           ; (fsk_xi, fsk_co) <- flatten_one rhs_ty
-                                  -- The fsk may already have been unified, so
-                                  -- flatten it
-                                  -- fsk_co :: fsk_xi ~ fsk
-                           ; let xi  = fsk_xi `mkCastTy` kind_co
-                                 co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co
-                                       `mkTransCo`
-                                       maybeTcSubCo eq_rel (mkSymCo co)
-                                       `mkTransCo` ret_co
-                           ; return (xi, co')
-                           }
-                                            -- :: fsk_xi ~ F xis
-
-                   -- Try to reduce the family application right now
-                   -- See Note [Reduce type family applications eagerly]
-                   _ -> do { mOut <- try_to_reduce tc
-                                                   xis
-                                                   kind_co
-                                                   (`mkTransCo` ret_co)
-                           ; case mOut of
-                               Just out -> pure out
-                               Nothing -> do
-                                 { loc <- getLoc
-                                 ; (ev, co, fsk) <- liftTcS $
-                                     newFlattenSkolem cur_flav loc tc xis
-
-                                 -- The new constraint (F xis ~ fsk) is not
-                                 -- necessarily inert (e.g. the LHS may be a
-                                 -- redex) so we must put it in the work list
-                                 ; let ct = CFunEqCan { cc_ev     = ev
-                                                      , cc_fun    = tc
-                                                      , cc_tyargs = xis
-                                                      , cc_fsk    = fsk }
-                                 ; emitFlatWork ct
-
-                                 ; traceFlat "flatten/flat-cache miss" $
-                                     (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev)
-
-                                 -- NB: fsk's kind is already flattened because
-                                 --     the xis are flattened
-                                 ; let fsk_ty = mkTyVarTy fsk
-                                       xi = fsk_ty `mkCastTy` kind_co
-                                       co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeTcSubCo eq_rel (mkSymCo co))
-                                             `mkTransCo` ret_co
-                                 ; return (xi, co')
-                                 }
-                           }
-               }
-        }
-
+-- See Note [How to normalise a family application]
+flatten_exact_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
+flatten_exact_fam_app tc tys
+  = do { checkStackDepth (mkTyConApp tc tys)
+
+       -- STEP 1/2. Try to reduce without reducing arguments first.
+       ; result1 <- try_to_reduce tc tys
+       ; case result1 of
+             -- Don't use the cache;
+             -- See Note [flatten_exact_fam_app performance]
+         { Just (co, xi) -> finish False (xi, co)
+         ; Nothing ->
+
+        -- That didn't work. So reduce the arguments, in STEP 3.
+    do { eq_rel <- getEqRel
+           -- checking eq_rel == NomEq saves ~0.5% in T9872a
+       ; (xis, cos, kind_co) <- if eq_rel == NomEq
+                                then flatten_args_tc tc Nothing tys
+                                else setEqRel NomEq $
+                                     flatten_args_tc tc Nothing tys
+           -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys)
+
+       ; let role    = eqRelRole eq_rel
+             args_co = mkTyConAppCo role tc cos
+           -- args_co :: F xis ~r F tys
+
+             homogenise :: TcType -> TcCoercion -> (TcType, TcCoercion)
+               -- in (xi', co') = homogenise xi co
+               --   assume co :: xi ~r F xis, co is homogeneous
+               --   then xi' :: tcTypeKind(F tys)
+               --   and co' :: xi' ~r F tys, which is homogeneous
+             homogenise xi co = homogenise_result xi (co `mkTcTransCo` args_co) role kind_co
+
+         -- STEP 4: try the inerts
+       ; result2 <- liftTcS $ lookupFamAppInert tc xis
+       ; flavour <- getFlavour
+       ; case result2 of
+         { Just (co, xi, fr@(_, inert_eq_rel))
+             -- co :: F xis ~ir xi
+
+             | fr `eqCanRewriteFR` (flavour, eq_rel) ->
+                 do { traceFlat "rewrite family application with inert"
+                                (ppr tc <+> ppr xis $$ ppr xi)
+                    ; finish True (homogenise xi downgraded_co) }
+               -- this will sometimes duplicate an inert in the cache,
+               -- but avoiding doing so had no impact on performance, and
+               -- it seems easier not to weed out that special case
+             where
+               inert_role    = eqRelRole inert_eq_rel
+               role          = eqRelRole eq_rel
+               downgraded_co = tcDowngradeRole role inert_role (mkTcSymCo co)
+                 -- downgraded_co :: xi ~r F xis
+
+         ; _ ->
+
+         -- inert didn't work. Try to reduce again, in STEP 5/6.
+    do { result3 <- try_to_reduce tc xis
+       ; case result3 of
+           Just (co, xi) -> finish True (homogenise xi co)
+           Nothing       -> -- we have made no progress at all: STEP 7.
+                            return (homogenise reduced (mkTcReflCo role reduced))
+             where
+               reduced = mkTyConApp tc xis }}}}}
   where
+      -- call this if the above attempts made progress.
+      -- This recursively flattens the result and then adds to the cache
+    finish :: Bool  -- add to the cache?
+           -> (Xi, Coercion) -> FlatM (Xi, Coercion)
+    finish use_cache (xi, co)
+      = do { -- flatten the result: FINISH 1
+             (fully, fully_co) <- bumpDepth $ flatten_one xi
+           ; let final_co = fully_co `mkTcTransCo` co
+           ; eq_rel <- getEqRel
+           ; flavour <- getFlavour
+
+             -- extend the cache: FINISH 2
+           ; when (use_cache && eq_rel == NomEq && flavour /= Derived) $
+             -- the cache only wants Nominal eqs
+             -- and Wanteds can rewrite Deriveds; the cache
+             -- has only Givens
+             liftTcS $ extendFamAppCache tc tys (final_co, fully)
+           ; return (fully, final_co) }
+    {-# INLINE finish #-}
 
-    -- try_to_reduce and try_to_reduce_nocache (below) could be unified into
-    -- a more general definition, but it was observed that separating them
-    -- gives better performance (lower allocation numbers in T9872x).
-
-    try_to_reduce :: TyCon   -- F, family tycon
-                  -> [Type]  -- args, not necessarily flattened
-                  -> CoercionN -- kind_co :: tcTypeKind(F args) ~N
-                               --            tcTypeKind(F orig_args)
-                               -- where
-                               -- orig_args is what was passed to the outer
-                               -- function
-                  -> (   Coercion     -- :: (xi |> kind_co) ~ F args
-                      -> Coercion )   -- what to return from outer function
-                  -> FlatM (Maybe (Xi, Coercion))
-    try_to_reduce tc tys kind_co update_co
-      = do { checkStackDepth (mkTyConApp tc tys)
-           ; mb_match <- liftTcS $ matchFam tc tys
-           ; case mb_match of
-                 -- NB: norm_co will always be homogeneous. All type families
-                 -- are homogeneous.
-               Just (norm_co, norm_ty)
-                 -> do { traceFlat "Eager T.F. reduction success" $
-                         vcat [ ppr tc, ppr tys, ppr norm_ty
-                              , ppr norm_co <+> dcolon
-                                            <+> ppr (coercionKind norm_co)
-                              ]
-                       ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty
-                       ; eq_rel <- getEqRel
-                       ; let co = maybeTcSubCo eq_rel norm_co
-                                   `mkTransCo` mkSymCo final_co
-                       ; flavour <- getFlavour
-                           -- NB: only extend cache with nominal equalities
-                       ; when (eq_rel == NomEq) $
-                         liftTcS $
-                         extendFlatCache tc tys ( co, xi, flavour )
-                       ; let role = eqRelRole eq_rel
-                             xi' = xi `mkCastTy` kind_co
-                             co' = update_co $
-                                   mkTcCoherenceLeftCo role xi kind_co (mkSymCo co)
-                       ; return $ Just (xi', co') }
-               Nothing -> pure Nothing }
-
-    try_to_reduce_nocache :: TyCon   -- F, family tycon
-                          -> [Type]  -- args, not necessarily flattened
-                          -> FlatM (Maybe (Xi, Coercion))
-    try_to_reduce_nocache tc tys
-      = do { checkStackDepth (mkTyConApp tc tys)
-           ; mb_match <- liftTcS $ matchFam tc tys
-           ; case mb_match of
-                 -- NB: norm_co will always be homogeneous. All type families
-                 -- are homogeneous.
-               Just (norm_co, norm_ty)
-                 -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty
-                       ; eq_rel <- getEqRel
-                       ; let co  = mkSymCo (maybeTcSubCo eq_rel norm_co
-                                            `mkTransCo` mkSymCo final_co)
-                       ; return $ Just (xi, co) }
-               Nothing -> pure Nothing }
-
-{- Note [Reduce type family applications eagerly]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we come across a type-family application like (Append (Cons x Nil) t),
-then, rather than flattening to a skolem etc, we may as well just reduce
-it on the spot to (Cons x t).  This saves a lot of intermediate steps.
-Examples that are helped are tests T9872, and T5321Fun.
-
-Performance testing indicates that it's best to try this *twice*, once
-before flattening arguments and once after flattening arguments.
-Adding the extra reduction attempt before flattening arguments cut
-the allocation amounts for the T9872{a,b,c} tests by half.
-
-An example of where the early reduction appears helpful:
-
-  type family Last x where
-    Last '[x]     = x
-    Last (h ': t) = Last t
-
-  workitem: (x ~ Last '[1,2,3,4,5,6])
-
-Flattening the argument never gets us anywhere, but trying to flatten
-it at every step is quadratic in the length of the list. Reducing more
-eagerly makes simplifying the right-hand type linear in its length.
-
-Testing also indicated that the early reduction should *not* use the
-flat-cache, but that the later reduction *should*. (Although the
-effect was not large.)  Hence the Bool argument to try_to_reduce.  To
-me (SLPJ) this seems odd; I get that eager reduction usually succeeds;
-and if don't use the cache for eager reduction, we will miss most of
-the opportunities for using it at all.  More exploration would be good
-here.
-
-At the end, once we've got a flat rhs, we extend the flatten-cache to record
-the result. Doing so can save lots of work when the same redex shows up more
-than once. Note that we record the link from the redex all the way to its
-*final* value, not just the single step reduction. Interestingly, using the
-flat-cache for the first reduction resulted in an increase in allocations
-of about 3% for the four T9872x tests. However, using the flat-cache in
-the later reduction is a similar gain. I (Richard E) don't currently (Dec '14)
-have any knowledge as to *why* these facts are true.
+-- Returned coercion is output ~r input, where r is the role in the FlatM monad
+-- See Note [How to normalise a family application]
+try_to_reduce :: TyCon -> [TcType] -> FlatM (Maybe (TcCoercion, TcType))
+try_to_reduce tc tys
+  = do { result <- liftTcS $ firstJustsM [ lookupFamAppCache tc tys  -- STEP 5
+                                         , matchFam tc tys ]         -- STEP 6
+       ; downgrade result }
+  where
+    -- The result above is always Nominal. We might want a Representational
+    -- coercion; this downgrades (and prints, out of convenience).
+    downgrade :: Maybe (TcCoercionN, TcType) -> FlatM (Maybe (TcCoercion, TcType))
+    downgrade Nothing = return Nothing
+    downgrade result@(Just (co, xi))
+      = do { traceFlat "Eager T.F. reduction success" $
+             vcat [ ppr tc, ppr tys, ppr xi
+                  , ppr co <+> dcolon <+> ppr (coercionKind co)
+                  ]
+           ; eq_rel <- getEqRel
+              -- manually doing it this way avoids allocation in the vastly
+              -- common NomEq case
+           ; case eq_rel of
+               NomEq  -> return result
+               ReprEq -> return (Just (mkSubCo co, xi)) }
 
+{-
 ************************************************************************
 *                                                                      *
              Flattening a type variable
@@ -1636,17 +947,15 @@ flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult
 
 flatten_tyvar2 tv fr@(_, eq_rel)
   = do { ieqs <- liftTcS $ getInertEqs
-       ; mode <- getMode
        ; case lookupDVarEnv ieqs tv of
-           Just (ct:_)   -- If the first doesn't work,
-                         -- the subsequent ones won't either
-             | CTyEqCan { cc_ev = ctev, cc_tyvar = tv
-                        , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct
+           Just (EqualCtList (ct :| _))   -- If the first doesn't work,
+                                          -- the subsequent ones won't either
+             | CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv
+                      , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct
              , let ct_fr = (ctEvFlavour ctev, ct_eq_rel)
              , ct_fr `eqCanRewriteFR` fr  -- This is THE key call of eqCanRewriteFR
              -> do { traceFlat "Following inert tyvar"
-                        (ppr mode <+>
-                         ppr tv <+>
+                        (ppr tv <+>
                          equals <+>
                          ppr rhs_ty $$ ppr ctev)
                     ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)
@@ -1688,239 +997,14 @@ only if (a) the work item can rewrite the inert AND
 
 This is significantly harder to think about. It can save a LOT of work
 in occurs-check cases, but we don't care about them much.  #5837
-is an example; all the constraints here are Givens
-
-             [G] a ~ TF (a,Int)
-    -->
-    work     TF (a,Int) ~ fsk
-    inert    fsk ~ a
-
-    --->
-    work     fsk ~ (TF a, TF Int)
-    inert    fsk ~ a
-
-    --->
-    work     a ~ (TF a, TF Int)
-    inert    fsk ~ a
-
-    ---> (attempting to flatten (TF a) so that it does not mention a
-    work     TF a ~ fsk2
-    inert    a ~ (fsk2, TF Int)
-    inert    fsk ~ (fsk2, TF Int)
-
-    ---> (substitute for a)
-    work     TF (fsk2, TF Int) ~ fsk2
-    inert    a ~ (fsk2, TF Int)
-    inert    fsk ~ (fsk2, TF Int)
-
-    ---> (top-level reduction, re-orient)
-    work     fsk2 ~ (TF fsk2, TF Int)
-    inert    a ~ (fsk2, TF Int)
-    inert    fsk ~ (fsk2, TF Int)
-
-    ---> (attempt to flatten (TF fsk2) to get rid of fsk2
-    work     TF fsk2 ~ fsk3
-    work     fsk2 ~ (fsk3, TF Int)
-    inert    a   ~ (fsk2, TF Int)
-    inert    fsk ~ (fsk2, TF Int)
+is an example, but it causes trouble only with the old (pre-Fall 2020)
+flattening story. It is unclear if there is any gain w.r.t. to
+the new story.
 
-    --->
-    work     TF fsk2 ~ fsk3
-    inert    fsk2 ~ (fsk3, TF Int)
-    inert    a   ~ ((fsk3, TF Int), TF Int)
-    inert    fsk ~ ((fsk3, TF Int), TF Int)
-
-Because the incoming given rewrites all the inert givens, we get more and
-more duplication in the inert set.  But this really only happens in pathological
-casee, so we don't care.
-
-
-************************************************************************
-*                                                                      *
-             Unflattening
-*                                                                      *
-************************************************************************
-
-An unflattening example:
-    [W] F a ~ alpha
-flattens to
-    [W] F a ~ fmv   (CFunEqCan)
-    [W] fmv ~ alpha (CTyEqCan)
-We must solve both!
 -}
 
-unflattenWanteds :: Cts -> Cts -> TcS Cts
-unflattenWanteds tv_eqs funeqs
- = do { tclvl    <- getTcLevel
-
-      ; traceTcS "Unflattening" $ braces $
-        vcat [ text "Funeqs =" <+> pprCts funeqs
-             , text "Tv eqs =" <+> pprCts tv_eqs ]
-
-         -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check
-         -- Occurs check: consider  [W] alpha ~ [F alpha]
-         --                 ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv]
-         --                 ==> (unify)   [W] F [fmv] ~ fmv
-         -- See Note [Unflatten using funeqs first]
-      ; funeqs <- foldrM unflatten_funeq emptyCts funeqs
-      ; traceTcS "Unflattening 1" $ braces (pprCts funeqs)
-
-          -- Step 2: unify the tv_eqs, if possible
-      ; tv_eqs  <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs
-      ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs)
-
-          -- Step 3: fill any remaining fmvs with fresh unification variables
-      ; funeqs <- mapBagM finalise_funeq funeqs
-      ; traceTcS "Unflattening 3" $ braces (pprCts funeqs)
-
-          -- Step 4: remove any tv_eqs that look like ty ~ ty
-      ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs
-
-      ; let all_flat = tv_eqs `andCts` funeqs
-      ; traceTcS "Unflattening done" $ braces (pprCts all_flat)
-
-      ; return all_flat }
-  where
-    ----------------
-    unflatten_funeq :: Ct -> Cts -> TcS Cts
-    unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis
-                                  , cc_fsk = fmv, cc_ev = ev }) rest
-      = do {   -- fmv should be an un-filled flatten meta-tv;
-               -- we now fix its final value by filling it, being careful
-               -- to observe the occurs check.  Zonking will eliminate it
-               -- altogether in due course
-             rhs' <- zonkTcType (mkTyConApp tc xis)
-           ; case occCheckExpand [fmv] rhs' of
-               Just rhs''    -- Normal case: fill the tyvar
-                 -> do { setReflEvidence ev NomEq rhs''
-                       ; unflattenFmv fmv rhs''
-                       ; return rest }
-
-               Nothing ->  -- Occurs check
-                          return (ct `consCts` rest) }
-
-    unflatten_funeq other_ct _
-      = pprPanic "unflatten_funeq" (ppr other_ct)
-
-    ----------------
-    finalise_funeq :: Ct -> TcS Ct
-    finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev })
-      = do { demoteUnfilledFmv fmv
-           ; return (mkNonCanonical ev) }
-    finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct)
-
-    ----------------
-    unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts
-    unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv
-                                    , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest
-
-      | NomEq <- eq_rel -- See Note [Do not unify representational equalities]
-                        --     in GHC.Tc.Solver.Interact
-      , isFmvTyVar tv   -- Previously these fmvs were untouchable,
-                        -- but now they are touchable
-                        -- NB: unlike unflattenFmv, filling a fmv here /does/
-                        --     bump the unification count; it is "improvement"
-                        -- Note [Unflattening can force the solver to iterate]
-      = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct )
-           -- CTyEqCan invariant (TyEq:K) should ensure this is true
-        do { is_filled <- isFilledMetaTyVar tv
-           ; elim <- case is_filled of
-               False -> do { traceTcS "unflatten_eq 2" (ppr ct)
-                           ; tryFill ev tv rhs }
-               True  -> do { traceTcS "unflatten_eq 3" (ppr ct)
-                           ; try_fill_rhs ev tclvl tv rhs }
-           ; if elim
-             then do { setReflEvidence ev eq_rel (mkTyVarTy tv)
-                     ; return rest }
-             else return (ct `consCts` rest) }
-
-      | otherwise
-      = return (ct `consCts` rest)
-
-    unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct)
-
-    ----------------
-    try_fill_rhs ev tclvl lhs_tv rhs
-         -- Constraint is lhs_tv ~ rhs_tv,
-         -- and lhs_tv is filled, so try RHS
-      | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs
-                             -- co :: kind(rhs_tv) ~ kind(lhs_tv)
-      , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv
-                              && not (isTyVarTyVar rhs_tv))
-                              -- LHS is a filled fmv, and so is a type
-                              -- family application, which a TyVarTv should
-                              -- not unify with
-      = do { is_filled <- isFilledMetaTyVar rhs_tv
-           ; if is_filled then return False
-             else tryFill ev rhs_tv
-                          (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) }
-
-      | otherwise
-      = return False
-
-    ----------------
-    finalise_eq :: Ct -> Cts -> TcS Cts
-    finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv
-                          , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest
-      | isFmvTyVar tv
-      = do { ty1 <- zonkTcTyVar tv
-           ; rhs' <- zonkTcType rhs
-           ; if ty1 `tcEqType` rhs'
-             then do { setReflEvidence ev eq_rel rhs'
-                     ; return rest }
-             else return (mkNonCanonical ev `consCts` rest) }
-
-      | otherwise
-      = return (mkNonCanonical ev `consCts` rest)
-
-    finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct)
-
-tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool
--- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv
--- If tv does not appear in 'rhs', it set tv := rhs,
--- binds the evidence (which should be a CtWanted) to Refl<rhs>
--- and return True.  Otherwise returns False
-tryFill ev tv rhs
-  = ASSERT2( not (isGiven ev), ppr ev )
-    do { rhs' <- zonkTcType rhs
-       ; case () of
-            _ | Just tv' <- tcGetTyVar_maybe rhs'
-              , tv == tv'   -- tv == rhs
-              -> return True
-
-            _ | Just rhs'' <- occCheckExpand [tv] rhs'
-              -> do {       -- Fill the tyvar
-                      unifyTyVar tv rhs''
-                    ; return True }
-
-            _ | otherwise   -- Occurs check
-              -> return False
-    }
-
-setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS ()
-setReflEvidence ev eq_rel rhs
-  = setEvBindIfWanted ev (evCoercion refl_co)
-  where
-    refl_co = mkTcReflCo (eqRelRole eq_rel) rhs
-
-{-
-Note [Unflatten using funeqs first]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-    [W] G a ~ Int
-    [W] F (G a) ~ G a
-
-do not want to end up with
-    [W] F Int ~ Int
-because that might actually hold!  Better to end up with the two above
-unsolved constraints.  The flat form will be
-
-    G a ~ fmv1     (CFunEqCan)
-    F fmv1 ~ fmv2  (CFunEqCan)
-    fmv1 ~ Int     (CTyEqCan)
-    fmv1 ~ fmv2    (CTyEqCan)
-
-Flatten using the fun-eqs first.
--}
+--------------------------------------
+-- Utilities
 
 -- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at
 -- least one named binder.
@@ -1946,6 +1030,6 @@ ty_con_binders_ty_binders' = foldr go ([], False)
     go (Bndr tv (NamedTCB vis)) (bndrs, _)
       = (Named (Bndr tv vis) : bndrs, True)
     go (Bndr tv (AnonTCB af))   (bndrs, n)
-      = (Anon af (unrestricted (tyVarKind tv))   : bndrs, n)
+      = (Anon af (tymult (tyVarKind tv)) : bndrs, n)
     {-# INLINE go #-}
 {-# INLINE ty_con_binders_ty_binders' #-}
diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs
index baa132c2b679e3935b42a35618bf9efe23aed5a9..49d4ad20abc3786532f4a3dacb8c22e6a7863a57 100644
--- a/compiler/GHC/Tc/Solver/Interact.hs
+++ b/compiler/GHC/Tc/Solver/Interact.hs
@@ -11,14 +11,12 @@ module GHC.Tc.Solver.Interact (
 #include "HsVersions.h"
 
 import GHC.Prelude
-import GHC.Types.Basic ( SwapFlag(..), isSwapped,
+import GHC.Types.Basic ( SwapFlag(..),
                          infinity, IntWithInf, intGtLimit )
 import GHC.Tc.Solver.Canonical
-import GHC.Tc.Solver.Flatten
-import GHC.Tc.Utils.Unify ( canSolveByUnification )
+import GHC.Tc.Utils.Unify( canSolveByUnification )
 import GHC.Types.Var.Set
 import GHC.Core.Type as Type
-import GHC.Core.Coercion        ( BlockSubstFlag(..) )
 import GHC.Core.InstEnv         ( DFunInstType )
 
 import GHC.Types.Var
@@ -57,6 +55,7 @@ import GHC.Types.Unique( hasKey )
 import GHC.Driver.Session
 import GHC.Utils.Misc
 import qualified GHC.LanguageExtensions as LangExt
+import Data.List.NonEmpty ( NonEmpty(..) )
 
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
@@ -90,50 +89,6 @@ Note [Basic Simplifier Plan]
 
 If in Step 1 no such element exists, we have exceeded our context-stack
 depth and will simply fail.
-
-Note [Unflatten after solving the simple wanteds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We unflatten after solving the wc_simples of an implication, and before attempting
-to float. This means that
-
- * The fsk/fmv flatten-skolems only survive during solveSimples.  We don't
-   need to worry about them across successive passes over the constraint tree.
-   (E.g. we don't need the old ic_fsk field of an implication.
-
- * When floating an equality outwards, we don't need to worry about floating its
-   associated flattening constraints.
-
- * Another tricky case becomes easy: #4935
-       type instance F True a b = a
-       type instance F False a b = b
-
-       [w] F c a b ~ gamma
-       (c ~ True) => a ~ gamma
-       (c ~ False) => b ~ gamma
-
-   Obviously this is soluble with gamma := F c a b, and unflattening
-   will do exactly that after solving the simple constraints and before
-   attempting the implications.  Before, when we were not unflattening,
-   we had to push Wanted funeqs in as new givens.  Yuk!
-
-   Another example that becomes easy: indexed_types/should_fail/T7786
-      [W] BuriedUnder sub k Empty ~ fsk
-      [W] Intersect fsk inv ~ s
-      [w] xxx[1] ~ s
-      [W] forall[2] . (xxx[1] ~ Empty)
-                   => Intersect (BuriedUnder sub k Empty) inv ~ Empty
-
-Note [Running plugins on unflattened wanteds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There is an annoying mismatch between solveSimpleGivens and
-solveSimpleWanteds, because the latter needs to fiddle with the inert
-set, unflatten and zonk the wanteds.  It passes the zonked wanteds
-to runTcPluginsWanteds, which produces a replacement set of wanteds,
-some additional insolubles and a flag indicating whether to go round
-the loop again.  If so, prepareInertsForImplications is used to remove
-the previous wanteds (which will still be in the inert set).  Note
-that prepareInertsForImplications will discard the insolubles, so we
-must keep track of them separately.
 -}
 
 solveSimpleGivens :: [Ct] -> TcS ()
@@ -177,48 +132,36 @@ solveSimpleWanteds simples
 
      | otherwise
      = do { -- Solve
-            (unif_count, wc1) <- solve_simple_wanteds wc
+            wc1 <- solve_simple_wanteds wc
 
             -- Run plugins
           ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1
-             -- See Note [Running plugins on unflattened wanteds]
 
-          ; if unif_count == 0 && not rerun_plugin
-            then return (n, wc2)             -- Done
-            else do { traceTcS "solveSimple going round again:" $
-                      ppr unif_count $$ ppr rerun_plugin
-                    ; go (n+1) limit wc2 } }      -- Loop
+          ; if rerun_plugin
+            then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin)
+                    ; go (n+1) limit wc2 }   -- Loop
+            else return (n, wc2) }           -- Done
 
 
-solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints)
+solve_simple_wanteds :: WantedConstraints -> TcS WantedConstraints
 -- Try solving these constraints
 -- Affects the unification state (of course) but not the inert set
 -- The result is not necessarily zonked
 solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_holes = holes })
   = nestTcS $
     do { solveSimples simples1
-       ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts
-       ; (unif_count, unflattened_eqs) <- reportUnifications $
-                                          unflattenWanteds tv_eqs fun_eqs
-            -- See Note [Unflatten after solving the simple wanteds]
-       ; return ( unif_count
-                , WC { wc_simple = others `andCts` unflattened_eqs
-                     , wc_impl   = implics1 `unionBags` implics2
-                     , wc_holes  = holes }) }
+       ; (implics2, unsolved) <- getUnsolvedInerts
+       ; return (WC { wc_simple = unsolved
+                    , wc_impl   = implics1 `unionBags` implics2
+                    , wc_holes  = holes }) }
 
 {- Note [The solveSimpleWanteds loop]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Solving a bunch of simple constraints is done in a loop,
 (the 'go' loop of 'solveSimpleWanteds'):
-  1. Try to solve them; unflattening may lead to improvement that
-     was not exploitable during solving
+  1. Try to solve them
   2. Try the plugin
-  3. If step 1 did improvement during unflattening; or if the plugin
-     wants to run again, go back to step 1
-
-Non-obviously, improvement can also take place during
-the unflattening that takes place in step (1). See GHC.Tc.Solver.Flatten,
-See Note [Unflattening can force the solver to iterate]
+  3. If the plugin wants to run again, go back to step 1
 -}
 
 -- The main solver loop implements Note [Basic Simplifier Plan]
@@ -481,15 +424,16 @@ or, equivalently,
 -- Interaction result of  WorkItem <~> Ct
 
 interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct)
--- Precondition: if the workitem is a CTyEqCan then it will not be able to
--- react with anything at this stage.
+-- Precondition: if the workitem is a CEqCan then it will not be able to
+-- react with anything at this stage (except, maybe, via a type family
+-- dependency)
 
 interactWithInertsStage wi
   = do { inerts <- getTcSInerts
+       ; lvl  <- getTcLevel
        ; let ics = inert_cans inerts
        ; case wi of
-             CTyEqCan  {} -> interactTyVarEq ics wi
-             CFunEqCan {} -> interactFunEq   ics wi
+             CEqCan    {} -> interactEq lvl  ics wi
              CIrredCan {} -> interactIrred   ics wi
              CDictCan  {} -> interactDict    ics wi
              _ -> pprPanic "interactWithInerts" (ppr wi) }
@@ -1127,6 +1071,8 @@ shortCutSolver dflags ev_w ev_i
 
                        ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)
                        ; loc' <- lift $ checkInstanceOK loc what pred
+                       ; lift $ checkReductionDepth loc' pred
+
 
                        ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds
                                   -- Emit work for subgoals but use our local cache
@@ -1298,113 +1244,63 @@ I can think of two ways to fix this:
 **********************************************************************
 -}
 
-interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
--- Try interacting the work item with the inert set
-interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc
-                                          , cc_tyargs = args, cc_fsk = fsk })
-  | Just inert_ct@(CFunEqCan { cc_ev = ev_i
-                             , cc_fsk = fsk_i })
-         <- findFunEq (inert_funeqs inerts) tc args
-  , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev
-  = do { traceTcS "reactFunEq (rewrite inert item):" $
-         vcat [ text "work_item =" <+> ppr work_item
-              , text "inertItem=" <+> ppr ev_i
-              , text "(swap_flag, upgrade)" <+> ppr pr ]
-       ; if isSwapped swap_flag
-         then do {   -- Rewrite inert using work-item
-                   let work_item' | upgrade_flag = upgradeWanted work_item
-                                  | otherwise    = work_item
-                 ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item'
-                      -- Do the updInertFunEqs before the reactFunEq, so that
-                      -- we don't kick out the inertItem as well as consuming it!
-                 ; reactFunEq ev fsk ev_i fsk_i
-                 ; stopWith ev "Work item rewrites inert" }
-         else do {   -- Rewrite work-item using inert
-                 ; when upgrade_flag $
-                   updInertFunEqs $ \ feqs -> insertFunEq feqs tc args
-                                                 (upgradeWanted inert_ct)
-                 ; reactFunEq ev_i fsk_i ev fsk
-                 ; stopWith ev "Inert rewrites work item" } }
-
-  | otherwise   -- Try improvement
-  = do { improveLocalFunEqs ev inerts tc args fsk
-       ; continueWith work_item }
-
-interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item)
-
-upgradeWanted :: Ct -> Ct
--- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2
--- so upgrade the [W] to [WD] before putting it in the inert set
-upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) }
-  where
-    upgrade_ev ev = ASSERT2( isWanted ev, ppr ct )
-                    ev { ctev_nosh = WDeriv }
-
-improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar
+improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType
                    -> TcS ()
 -- Generate derived improvement equalities, by comparing
 -- the current work item with inert CFunEqs
 -- E.g.   x + y ~ z,   x + y' ~ z   =>   [D] y ~ y'
 --
 -- See Note [FunDep and implicit parameter reactions]
-improveLocalFunEqs work_ev inerts fam_tc args fsk
-  | isGiven work_ev -- See Note [No FunEq improvement for Givens]
-    || not (isImprovable work_ev)
-  = return ()
-
-  | otherwise
-  = do { eqns <- improvement_eqns
-       ; if not (null eqns)
-         then do { traceTcS "interactFunEq improvements: " $
-                   vcat [ text "Eqns:" <+> ppr eqns
+-- Precondition: isImprovable work_ev
+improveLocalFunEqs work_ev inerts fam_tc args rhs
+  = ASSERT( isImprovable work_ev )
+    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) ]
-                 ; emitFunDepDeriveds eqns }
-         else return () }
-
+       ; emitFunDepDeriveds improvement_eqns }
   where
     funeqs        = inert_funeqs inerts
-    funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc
+    funeqs_for_tc = [ funeq_ct | EqualCtList (funeq_ct :| _)
+                                   <- findFunEqsByTyCon funeqs fam_tc
+                               , 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 :: TcS [FunDepEqn CtLoc]
+    improvement_eqns :: [FunDepEqn CtLoc]
     improvement_eqns
       | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
       =    -- Try built-in families, notably for arithmethic
-        do { rhs <- rewriteTyVar fsk
-           ; concatMapM (do_one_built_in ops rhs) funeqs_for_tc }
+        concatMap (do_one_built_in ops rhs) funeqs_for_tc
 
       | Injective injective_args <- fam_inj_info
       =    -- Try improvement from type families with injectivity annotations
-        do { rhs <- rewriteTyVar fsk
-           ; concatMapM (do_one_injective injective_args rhs) funeqs_for_tc }
+        concatMap (do_one_injective injective_args rhs) funeqs_for_tc
 
       | otherwise
-      = return []
+      = []
 
     --------------------
-    do_one_built_in ops rhs (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev })
-      = do { inert_rhs <- rewriteTyVar ifsk
-           ; return $ mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs inert_rhs) }
+    do_one_built_in ops rhs (CEqCan { cc_lhs = TyFamLHS _ iargs, cc_rhs = irhs, cc_ev = inert_ev })
+      = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs)
 
     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 (CFunEqCan { cc_tyargs = inert_args
-                                             , cc_fsk = ifsk, cc_ev = inert_ev })
+    do_one_injective inj_args rhs (CEqCan { cc_lhs = TyFamLHS _ inert_args
+                                          , cc_rhs = irhs, cc_ev = inert_ev })
       | isImprovable inert_ev
-      = do { inert_rhs <- rewriteTyVar ifsk
-           ; return $ if rhs `tcEqType` inert_rhs
-                      then mk_fd_eqns inert_ev $
-                             [ Pair arg iarg
-                             | (arg, iarg, True) <- zip3 args inert_args inj_args ]
-                      else [] }
+      , rhs `tcEqType` irhs
+      = mk_fd_eqns inert_ev $ [ Pair arg iarg
+                              | (arg, iarg, True) <- zip3 args inert_args inj_args ]
       | otherwise
-      = return []
+      = []
 
     do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)
 
@@ -1421,26 +1317,13 @@ improveLocalFunEqs work_ev inerts fam_tc args fsk
         loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`
                                       ctl_depth work_loc }
 
--------------
-reactFunEq :: CtEvidence -> TcTyVar    -- From this  :: F args1 ~ fsk1
-           -> CtEvidence -> TcTyVar    -- Solve this :: F args2 ~ fsk2
-           -> TcS ()
-reactFunEq from_this fsk1 solve_this fsk2
-  = do { traceTcS "reactFunEq"
-            (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2])
-       ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1)
-       ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$
-                                     ppr solve_this $$ ppr fsk2) }
-
 {- 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 two CFunEqCan constraints for F with the same RHS
-   F s1 t1 ~ rhs
-   F s2 t2 ~ rhs
-then we can use the injectivity to get a new Derived constraint on
+Then if we have an equality like F s1 t1 ~ F s2 t2,
+we can use the injectivity to get a new Derived constraint on
 the injective argument
   [D] t1 ~ t2
 
@@ -1467,8 +1350,20 @@ 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).
 
-See also Note [Injective type families] in GHC.Core.TyCon
+We generate these Deriveds in three places, depending on how we notice the
+injectivity.
+
+1. When we have a [W/D] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and
+described in Note [Decomposing equality] 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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1501,85 +1396,34 @@ 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.
 
-
-Note [Efficient Orientation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we are interacting two FunEqCans with the same LHS:
-          (inert)  ci :: (F ty ~ xi_i)
-          (work)   cw :: (F ty ~ xi_w)
-We prefer to keep the inert (else we pass the work item on down
-the pipeline, which is a bit silly).  If we keep the inert, we
-will (a) discharge 'cw'
-     (b) produce a new equality work-item (xi_w ~ xi_i)
-Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w):
-    new_work :: xi_w ~ xi_i
-    cw := ci ; sym new_work
-Why?  Consider the simplest case when xi1 is a type variable.  If
-we generate xi1~xi2, processing that constraint will kick out 'ci'.
-If we generate xi2~xi1, there is less chance of that happening.
-Of course it can and should still happen if xi1=a, xi1=Int, say.
-But we want to avoid it happening needlessly.
-
-Similarly, if we *can't* keep the inert item (because inert is Wanted,
-and work is Given, say), we prefer to orient the new equality (xi_i ~
-xi_w).
-
-Note [Carefully solve the right CFunEqCan]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   ---- OLD COMMENT, NOW NOT NEEDED
-   ---- because we now allow multiple
-   ---- wanted FunEqs with the same head
-Consider the constraints
-  c1 :: F Int ~ a      -- Arising from an application line 5
-  c2 :: F Int ~ Bool   -- Arising from an application line 10
-Suppose that 'a' is a unification variable, arising only from
-flattening.  So there is no error on line 5; it's just a flattening
-variable.  But there is (or might be) an error on line 10.
-
-Two ways to combine them, leaving either (Plan A)
-  c1 :: F Int ~ a      -- Arising from an application line 5
-  c3 :: a ~ Bool       -- Arising from an application line 10
-or (Plan B)
-  c2 :: F Int ~ Bool   -- Arising from an application line 10
-  c4 :: a ~ Bool       -- Arising from an application line 5
-
-Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error
-on the *totally innocent* line 5.  An example is test SimpleFail16
-where the expected/actual message comes out backwards if we use
-the wrong plan.
-
-The second is the right thing to do.  Hence the isMetaTyVarTy
-test when solving pairwise CFunEqCan.
-
-
 **********************************************************************
 *                                                                    *
-                   interactTyVarEq
+                   interactEq
 *                                                                    *
 **********************************************************************
 -}
 
-inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole
+inertsCanDischarge :: InertCans -> CanEqLHS -> TcType -> CtFlavourRole
                    -> Maybe ( CtEvidence  -- The evidence for the inert
                             , SwapFlag    -- Whether we need mkSymCo
                             , Bool)       -- True <=> keep a [D] version
                                           --          of the [WD] constraint
-inertsCanDischarge inerts tv rhs fr
-  | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i
-                                    , cc_eq_rel = eq_rel }
-                             <- findTyEqs inerts tv
+inertsCanDischarge inerts lhs rhs fr
+  | (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i
+                                  , cc_eq_rel = eq_rel }
+                             <- findEq inerts lhs
                          , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr
                          , rhs_i `tcEqType` rhs ]
   =  -- Inert:     a ~ ty
      -- Work item: a ~ ty
     Just (ev_i, NotSwapped, keep_deriv ev_i)
 
-  | Just tv_rhs <- getTyVar_maybe rhs
-  , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i
-                                    , cc_eq_rel = eq_rel }
-                             <- findTyEqs inerts tv_rhs
+  | Just rhs_lhs <- canEqLHS_maybe rhs
+  , (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i
+                                  , cc_eq_rel = eq_rel }
+                             <- findEq inerts rhs_lhs
                          , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr
-                         , rhs_i `tcEqType` mkTyVarTy tv ]
+                         , rhs_i `tcEqType` canEqLHSType lhs ]
   =  -- Inert:     a ~ b
      -- Work item: b ~ a
      Just (ev_i, IsSwapped, keep_deriv ev_i)
@@ -1595,16 +1439,15 @@ inertsCanDischarge inerts tv rhs fr
       | otherwise
       = False  -- Work item is fully discharged
 
-interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
--- CTyEqCans are always consumed, so always returns Stop
-interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv
-                                          , cc_rhs = rhs
-                                          , cc_ev = ev
-                                          , cc_eq_rel = eq_rel })
+interactEq :: TcLevel -> InertCans -> Ct -> TcS (StopOrContinue Ct)
+interactEq tclvl inerts workItem@(CEqCan { cc_lhs = lhs
+                                         , cc_rhs = rhs
+                                         , cc_ev = ev
+                                         , cc_eq_rel = eq_rel })
   | Just (ev_i, swapped, keep_deriv)
-       <- inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel)
+       <- inertsCanDischarge inerts lhs rhs (ctEvFlavour ev, eq_rel)
   = do { setEvBindIfWanted ev $
-         evCoercion (maybeSym swapped $
+         evCoercion (maybeTcSymCo swapped $
                      tcDowngradeRole (eqRelRole eq_rel)
                                      (ctEvRole ev_i)
                                      (ctEvCoercion ev_i))
@@ -1622,19 +1465,22 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv
   = do { traceTcS "Not unifying representational equality" (ppr workItem)
        ; continueWith workItem }
 
-  | isGiven ev         -- See Note [Touchables and givens]
-  = continueWith workItem
+    -- try improvement, if possible
+  | TyFamLHS fam_tc fam_args <- lhs
+  , isImprovable ev
+  = do { improveLocalFunEqs ev inerts fam_tc fam_args rhs
+       ; continueWith workItem }
 
-  | otherwise
-  = do { tclvl <- getTcLevel
-       ; if canSolveByUnification tclvl tv rhs
-         then do { solveByUnification ev tv rhs
-                 ; n_kicked <- kickOutAfterUnification tv
-                 ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) }
+  | TyVarLHS tv <- lhs
+  , canSolveByUnification tclvl tv rhs
+  = do { solveByUnification ev tv rhs
+       ; n_kicked <- kickOutAfterUnification tv
+       ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) }
 
-         else continueWith workItem }
+  | otherwise
+  = continueWith workItem
 
-interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)
+interactEq _ _ wi = pprPanic "interactEq" (ppr wi)
 
 solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS ()
 -- Solve with the identity coercion
@@ -1645,7 +1491,7 @@ solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS ()
 --        workItem = the new Given constraint
 --
 -- NB: No need for an occurs check here, because solveByUnification always
---     arises from a CTyEqCan, a *canonical* constraint.  Its invariant (TyEq:OC)
+--     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.
 --
@@ -1694,7 +1540,7 @@ where
 and we want to get alpha := N b.
 
 See also #15144, which was caused by unifying a representational
-equality (in the unflattener).
+equality.
 
 
 ************************************************************************
@@ -1822,9 +1668,8 @@ topReactionsStage work_item
        ; case work_item of
            CDictCan {}  -> do { inerts <- getTcSInerts
                               ; doTopReactDict inerts work_item }
-           CFunEqCan {} -> doTopReactFunEq work_item
+           CEqCan {}    -> doTopReactEq    work_item
            CIrredCan {} -> doTopReactOther work_item
-           CTyEqCan {}  -> doTopReactOther work_item
            _  -> -- Any other work item does not react with any top-level equations
                  continueWith work_item  }
 
@@ -1832,7 +1677,7 @@ topReactionsStage work_item
 --------------------
 doTopReactOther :: Ct -> TcS (StopOrContinue Ct)
 -- Try local quantified constraints for
---     CTyEqCan  e.g.  (a ~# ty)
+--     CEqCan    e.g.  (lhs ~# ty)
 -- and CIrredCan e.g.  (c a)
 --
 -- Why equalities? See GHC.Tc.Solver.Canonical
@@ -1889,126 +1734,24 @@ See
  * Note [Evidence for quantified constraints] in GHC.Core.Predicate
  * Note [Equality superclasses in quantified constraints]
    in GHC.Tc.Solver.Canonical
-
-Note [Flatten when discharging CFunEqCan]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have the following scenario (#16512):
-
-type family LV (as :: [Type]) (b :: Type) = (r :: Type) | r -> as b where
-  LV (a ': as) b = a -> LV as b
-
-[WD] w1 :: LV as0 (a -> b) ~ fmv1 (CFunEqCan)
-[WD] w2 :: fmv1 ~ (a -> fmv2) (CTyEqCan)
-[WD] w3 :: LV as0 b ~ fmv2 (CFunEqCan)
-
-We start with w1. Because LV is injective, we wish to see if the RHS of the
-equation matches the RHS of the CFunEqCan. The RHS of a CFunEqCan is always an
-fmv, so we "look through" to get (a -> fmv2). Then we run tcUnifyTyWithTFs.
-That performs the match, but it allows a type family application (such as the
-LV in the RHS of the equation) to match with anything. (See "Injective type
-families" by Stolarek et al., HS'15, Fig. 2) The matching succeeds, which
-means we can improve as0 (and b, but that's not interesting here). However,
-because the RHS of w1 can't see through fmv2 (we have no way of looking up a
-LHS of a CFunEqCan from its RHS, and this use case isn't compelling enough),
-we invent a new unification variable here. We thus get (as0 := a : as1).
-Rewriting:
-
-[WD] w1 :: LV (a : as1) (a -> b) ~ fmv1
-[WD] w2 :: fmv1 ~ (a -> fmv2)
-[WD] w3 :: LV (a : as1) b ~ fmv2
-
-We can now reduce both CFunEqCans, using the equation for LV. We get
-
-[WD] w2 :: (a -> LV as1 (a -> b)) ~ (a -> a -> LV as1 b)
-
-Now we decompose (and flatten) to
-
-[WD] w4 :: LV as1 (a -> b) ~ fmv3
-[WD] w5 :: fmv3 ~ (a -> fmv1)
-[WD] w6 :: LV as1 b ~ fmv4
-
-which is exactly where we started. These goals really are insoluble, but
-we would prefer not to loop. We thus need to find a way to bump the reduction
-depth, so that we can detect the loop and abort.
-
-The key observation is that we are performing a reduction. We thus wish
-to bump the level when discharging a CFunEqCan. Where does this bumped
-level go, though? It can't just go on the reduct, as that's a type. Instead,
-it must go on any CFunEqCans produced after flattening. We thus flatten
-when discharging, making sure that the level is bumped in the new
-fun-eqs. The flattening happens in reduce_top_fun_eq and the level
-is bumped when setting up the FlatM monad in GHC.Tc.Solver.Flatten.runFlatten.
-(This bumping will happen for call sites other than this one, but that
-makes sense -- any constraints emitted by the flattener are offshoots
-the work item and should have a higher level. We don't have any test
-cases that require the bumping in this other cases, but it's convenient
-and causes no harm to bump at every flatten.)
-
-Test case: typecheck/should_fail/T16512a
-
 -}
 
 --------------------
-doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct)
-doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc
-                                     , cc_tyargs = args, cc_fsk = fsk })
-
-  | fsk `elemVarSet` tyCoVarsOfTypes args
-  = no_reduction    -- See Note [FunEq occurs-check principle]
-
-  | otherwise  -- Note [Reduction for Derived CFunEqCans]
-  = do { match_res <- matchFam fam_tc args
-                           -- Look up in top-level instances, or built-in axiom
-                           -- See Note [MATCHING-SYNONYMS]
-       ; case match_res of
-           Nothing         -> no_reduction
-           Just match_info -> reduce_top_fun_eq old_ev fsk match_info }
-  where
-    no_reduction
-      = do { improveTopFunEqs old_ev fam_tc args fsk
-           ; continueWith work_item }
-
-doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w)
-
-reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType)
-                  -> TcS (StopOrContinue Ct)
--- We have found an applicable top-level axiom: use it to reduce
--- Precondition: fsk is not free in rhs_ty
--- ax_co :: F tys ~ rhs_ty, where F tys is the LHS of the old_ev
-reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty)
-  | not (isDerived old_ev)  -- Precondition of shortCutReduction
-  , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty
-  , isTypeFamilyTyCon tc
-  , tc_args `lengthIs` tyConArity tc    -- Short-cut
-  = -- RHS is another type-family application
-    -- Try shortcut; see Note [Top-level reductions for type functions]
-    do { shortCutReduction old_ev fsk ax_co tc tc_args
-       ; stopWith old_ev "Fun/Top (shortcut)" }
-
-  | otherwise
-  = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty)
-           , ppr old_ev $$ ppr rhs_ty )
-           -- Guaranteed by Note [FunEq occurs-check principle]
-    do { (rhs_xi, flatten_co) <- flatten FM_FlattenAll old_ev rhs_ty
-             -- flatten_co :: rhs_xi ~ rhs_ty
-             -- See Note [Flatten when discharging CFunEqCan]
-       ; let total_co = ax_co `mkTcTransCo` mkTcSymCo flatten_co
-       ; dischargeFunEq old_ev fsk total_co rhs_xi
-       ; traceTcS "doTopReactFunEq" $
-         vcat [ text "old_ev:" <+> ppr old_ev
-              , nest 2 (text ":=") <+> ppr ax_co ]
-       ; stopWith old_ev "Fun/Top" }
-
-improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS ()
+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 fsk
-  | isGiven ev            -- See Note [No FunEq improvement for Givens]
-    || not (isImprovable ev)
+improveTopFunEqs ev fam_tc args rhs
+  | not (isImprovable ev)
   = return ()
 
   | otherwise
   = do { fam_envs <- getFamInstEnvs
-       ; rhs <- rewriteTyVar fsk
        ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs
        ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs
                                           , ppr eqns ])
@@ -2090,127 +1833,7 @@ improve_top_fun_eqs fam_envs fam_tc args rhs_ty
                           _          -> True
                       , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] }
 
-
-shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion
-                  -> TyCon -> [TcType] -> TcS ()
--- See Note [Top-level reductions for type functions]
--- Previously, we flattened the tc_args here, but there's no need to do so.
--- And, if we did, this function would have all the complication of
--- GHC.Tc.Solver.Canonical.canCFunEqCan. See Note [canCFunEqCan]
-shortCutReduction old_ev fsk ax_co fam_tc tc_args
-  = ASSERT( ctEvEqRel old_ev == NomEq)
-               -- ax_co :: F args ~ G tc_args
-               -- old_ev :: F args ~ fsk
-    do { new_ev <- case ctEvFlavour old_ev of
-           Given -> newGivenEvVar deeper_loc
-                         ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)
-                         , evCoercion (mkTcSymCo ax_co
-                                       `mkTcTransCo` ctEvCoercion old_ev) )
-
-           Wanted {} ->
-             -- See TcCanonical Note [Equalities with incompatible kinds] about NoBlockSubst
-             do { (new_ev, new_co) <- newWantedEq_SI NoBlockSubst WDeriv deeper_loc Nominal
-                                        (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)
-                ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co
-                ; return new_ev }
-
-           Derived -> pprPanic "shortCutReduction" (ppr old_ev)
-
-       ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc
-                                , cc_tyargs = tc_args, cc_fsk = fsk }
-       ; updWorkListTcS (extendWorkListFunEq new_ct) }
-  where
-    deeper_loc = bumpCtLocDepth (ctEvLoc old_ev)
-
-{- Note [Top-level reductions for type functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-c.f. Note [The flattening story] in GHC.Tc.Solver.Flatten
-
-Suppose we have a CFunEqCan  F tys ~ fmv/fsk, and a matching axiom.
-Here is what we do, in four cases:
-
-* Wanteds: general firing rule
-    (work item) [W]        x : F tys ~ fmv
-    instantiate axiom: ax_co : F tys ~ rhs
-
-   Then:
-      Discharge   fmv := rhs
-      Discharge   x := ax_co ; sym x2
-   This is *the* way that fmv's get unified; even though they are
-   "untouchable".
-
-   NB: Given Note [FunEq occurs-check principle], fmv does not appear
-   in tys, and hence does not appear in the instantiated RHS.  So
-   the unification can't make an infinite type.
-
-* Wanteds: short cut firing rule
-  Applies when the RHS of the axiom is another type-function application
-      (work item)        [W] x : F tys ~ fmv
-      instantiate axiom: ax_co : F tys ~ G rhs_tys
-
-  It would be a waste to create yet another fmv for (G rhs_tys).
-  Instead (shortCutReduction):
-      - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis)
-      - Add G rhs_xis ~ fmv to flat cache  (note: the same old fmv)
-      - New canonical wanted   [W] x2 : G rhs_xis ~ fmv  (CFunEqCan)
-      - Discharge x := ax_co ; G cos ; x2
-
-* Givens: general firing rule
-      (work item)        [G] g : F tys ~ fsk
-      instantiate axiom: ax_co : F tys ~ rhs
-
-   Now add non-canonical given (since rhs is not flat)
-      [G] (sym g ; ax_co) : fsk ~ rhs  (Non-canonical)
-
-* Givens: short cut firing rule
-  Applies when the RHS of the axiom is another type-function application
-      (work item)        [G] g : F tys ~ fsk
-      instantiate axiom: ax_co : F tys ~ G rhs_tys
-
-  It would be a waste to create yet another fsk for (G rhs_tys).
-  Instead (shortCutReduction):
-     - Flatten rhs_tys: flat_cos : tys ~ flat_tys
-     - Add new Canonical given
-          [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk   (CFunEqCan)
-
-Note [FunEq occurs-check principle]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-I have spent a lot of time finding a good way to deal with
-CFunEqCan constraints like
-    F (fuv, a) ~ fuv
-where flatten-skolem occurs on the LHS.  Now in principle we
-might may progress by doing a reduction, but in practice its
-hard to find examples where it is useful, and easy to find examples
-where we fall into an infinite reduction loop.  A rule that works
-very well is this:
-
-  *** FunEq occurs-check principle ***
-
-      Do not reduce a CFunEqCan
-          F tys ~ fsk
-      if fsk appears free in tys
-      Instead we treat it as stuck.
-
-Examples:
-
-* #5837 has [G] a ~ TF (a,Int), with an instance
-    type instance TF (a,b) = (TF a, TF b)
-  This readily loops when solving givens.  But with the FunEq occurs
-  check principle, it rapidly gets stuck which is fine.
-
-* #12444 is a good example, explained in comment:2.  We have
-    type instance F (Succ x) = Succ (F x)
-    [W] alpha ~ Succ (F alpha)
-  If we allow the reduction to happen, we get an infinite loop
-
-Note [Cached solved FunEqs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When trying to solve, say (FunExpensive big-type ~ ty), it's important
-to see if we have reduced (FunExpensive big-type) before, lest we
-simply repeat it.  Hence the lookup in inert_solved_funeqs.  Moreover
-we must use `funEqCanDischarge` because both uses might (say) be Wanteds,
-and we *still* want to save the re-computation.
-
+{-
 Note [MATCHING-SYNONYMS]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 When trying to match a dictionary (D tau) to a top-level instance, or a
@@ -2254,68 +1877,6 @@ kinds much match too; so it's easier to let the normal machinery
 handle it.  Instead we are careful to orient the new derived
 equality with the template on the left.  Delicate, but it works.
 
-Note [No FunEq improvement for Givens]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We don't do improvements (injectivity etc) for Givens. Why?
-
-* It generates Derived constraints on skolems, which don't do us
-  much good, except perhaps identify inaccessible branches.
-  (They'd be perfectly valid though.)
-
-* For type-nat stuff the derived constraints include type families;
-  e.g.  (a < b), (b < c) ==> a < c If we generate a Derived for this,
-  we'll generate a Derived/Wanted CFunEqCan; and, since the same
-  InertCans (after solving Givens) are used for each iteration, that
-  massively confused the unflattening step (GHC.Tc.Solver.Flatten.unflatten).
-
-  In fact it led to some infinite loops:
-     indexed-types/should_compile/T10806
-     indexed-types/should_compile/T10507
-     polykinds/T10742
-
-Note [Reduction for Derived CFunEqCans]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-You may wonder if it's important to use top-level instances to
-simplify [D] CFunEqCan's.  But it is.  Here's an example (T10226).
-
-   type instance F    Int = Int
-   type instance FInv Int = Int
-
-Suppose we have to solve
-    [WD] FInv (F alpha) ~ alpha
-    [WD] F alpha ~ Int
-
-  --> flatten
-    [WD] F alpha ~ fuv0
-    [WD] FInv fuv0 ~ fuv1  -- (A)
-    [WD] fuv1 ~ alpha
-    [WD] fuv0 ~ Int        -- (B)
-
-  --> Rewwrite (A) with (B), splitting it
-    [WD] F alpha ~ fuv0
-    [W] FInv fuv0 ~ fuv1
-    [D] FInv Int ~ fuv1    -- (C)
-    [WD] fuv1 ~ alpha
-    [WD] fuv0 ~ Int
-
-  --> Reduce (C) with top-level instance
-      **** This is the key step ***
-    [WD] F alpha ~ fuv0
-    [W] FInv fuv0 ~ fuv1
-    [D] fuv1 ~ Int        -- (D)
-    [WD] fuv1 ~ alpha     -- (E)
-    [WD] fuv0 ~ Int
-
-  --> Rewrite (D) with (E)
-    [WD] F alpha ~ fuv0
-    [W] FInv fuv0 ~ fuv1
-    [D] alpha ~ Int       -- (F)
-    [WD] fuv1 ~ alpha
-    [WD] fuv0 ~ Int
-
-  --> unify (F)  alpha := Int, and that solves it
-
-Another example is indexed-types/should_compile/T10634
 -}
 
 {- *******************************************************************
@@ -2379,47 +1940,48 @@ chooseInstance work_item
                         , cir_mk_ev     = mk_ev })
   = do { traceTcS "doTopReact/found instance for" $ ppr ev
        ; deeper_loc <- checkInstanceOK loc what pred
-       ; if isDerived ev then finish_derived deeper_loc theta
-                         else finish_wanted  deeper_loc theta mk_ev }
+       ; if isDerived ev
+         then -- Use type-class instances for Deriveds, in the hope
+              -- of generating some improvements
+              -- C.f. Example 3 of Note [The improvement story]
+              -- It's easy because no evidence is involved
+           do { dflags <- getDynFlags
+              ; unless (subGoalDepthExceeded dflags (ctLocDepth deeper_loc)) $
+                emitNewDeriveds deeper_loc theta
+                  -- If we have a runaway Derived, let's not issue a
+                  -- "reduction stack overflow" error, which is not particularly
+                  -- friendly. Instead, just drop the Derived.
+              ; traceTcS "finish_derived" (ppr (ctl_depth deeper_loc))
+              ; stopWith ev "Dict/Top (solved derived)" }
+
+         else -- wanted
+           do { 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) theta
+              ; setEvBindIfWanted ev (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
 
-     finish_wanted :: CtLoc -> [TcPredType]
-                   -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct)
-      -- Precondition: evidence term matches the predicate workItem
-     finish_wanted loc theta mk_ev
-        = do { evb <- getTcEvBindsVar
-             ; if isCoEvBindsVar evb
-               then -- See Note [Instances in no-evidence implications]
-                    continueWith work_item
-               else
-          do { evc_vars <- mapM (newWanted loc) theta
-             ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))
-             ; emitWorkNC (freshGoals evc_vars)
-             ; stopWith ev "Dict/Top (solved wanted)" } }
-
-     finish_derived loc theta
-       = -- Use type-class instances for Deriveds, in the hope
-         -- of generating some improvements
-         -- C.f. Example 3 of Note [The improvement story]
-         -- It's easy because no evidence is involved
-         do { emitNewDeriveds loc theta
-            ; traceTcS "finish_derived" (ppr (ctl_depth loc))
-            ; stopWith ev "Dict/Top (solved derived)" }
-
 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 insstance:
 --    (a) the use is well staged in the Template Haskell sense
---    (b) we have not recursed too deep
 -- Returns the CtLoc to used for sub-goals
+-- Probably also want to call checkReductionDepth, but this function
+-- does not do so to enable special handling for Deriveds in chooseInstance
 checkInstanceOK loc what pred
   = do { checkWellStagedDFun loc what pred
-       ; checkReductionDepth deeper_loc pred
        ; return deeper_loc }
   where
      deeper_loc = zap_origin (bumpCtLocDepth loc)
@@ -2460,7 +2022,7 @@ 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.
--- ee Note [Instance and Given overlap]
+-- See Note [Instance and Given overlap]
   | not (xopt LangExt.IncoherentInstances dflags)
   , not (naturallyCoherentClass clas)
   , let matchable_givens = matchableGivens loc pred inerts
@@ -2533,7 +2095,7 @@ The partial solution is that:
 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
-#4981 and #5002.
+tickets #4981 and #5002.
 
 Other notes:
 
@@ -2543,12 +2105,7 @@ Other notes:
      - natural numbers
      - Typeable
 
-* Flatten-skolems: we do not treat a flatten-skolem as unifiable
-  for this purpose.
-  E.g.   f :: Eq (F a) => [a] -> [a]
-         f xs = ....(xs==xs).....
-  Here we get [W] Eq [a], and we don't want to refrain from solving
-  it because of the given (Eq (F a)) constraint!
+* See also Note [What might match later?] in GHC.Tc.Solver.Monad.
 
 * The given-overlap problem is arguably not easy to appear in practice
   due to our aggressive prioritization of equality solving over other
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 64a80b2e945f26e6d87f82db91926d986b13b3a5..80f6e7f3a86e4d1d23983ab4a2089cedc575c427 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-}
+{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies, ScopedTypeVariables, TypeApplications,
+             DerivingStrategies, GeneralizedNewtypeDeriving #-}
 
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}
 
 -- | Type definitions for the constraint solver
 module GHC.Tc.Solver.Monad (
@@ -8,10 +9,10 @@ module GHC.Tc.Solver.Monad (
     -- The work list
     WorkList(..), isEmptyWorkList, emptyWorkList,
     extendWorkListNonEq, extendWorkListCt,
-    extendWorkListCts, extendWorkListEq, extendWorkListFunEq,
+    extendWorkListCts, extendWorkListEq,
     appendWorkList,
     selectNextWorkItem,
-    workListSize, workListWantedCount,
+    workListSize,
     getWorkList, updWorkListTcS, pushLevelNoWorkList,
 
     -- The TcS monad
@@ -40,7 +41,7 @@ module GHC.Tc.Solver.Monad (
     newWantedNC, newWantedEvVarNC,
     newDerivedNC,
     newBoundEvVarId,
-    unifyTyVar, unflattenFmv, reportUnifications,
+    unifyTyVar, reportUnifications,
     setEvBind, setWantedEq,
     setWantedEvTerm, setEvBindIfWanted,
     newEvVar, newGivenEvVar, newGivenEvVars,
@@ -57,7 +58,7 @@ module GHC.Tc.Solver.Monad (
     -- Inerts
     InertSet(..), InertCans(..), emptyInert,
     updInertTcS, updInertCans, updInertDicts, updInertIrreds,
-    getNoGivenEqs, setInertCans,
+    getHasGivenEqs, setInertCans,
     getInertEqs, getInertCans, getInertGivens,
     getInertInsols,
     getTcSInerts, setTcSInerts,
@@ -79,9 +80,9 @@ module GHC.Tc.Solver.Monad (
     DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,
     addDictsByClass, delDict, foldDicts, filterDicts, findDict,
 
-    -- Inert CTyEqCans
-    EqualCtList, findTyEqs, foldTyEqs, isInInertEqs,
-    lookupInertTyVar,
+    -- Inert CEqCans
+    EqualCtList(..), findTyEqs, foldTyEqs,
+    findEq,
 
     -- Inert solved dictionaries
     addSolvedDict, lookupSolvedDict,
@@ -90,18 +91,17 @@ module GHC.Tc.Solver.Monad (
     foldIrreds,
 
     -- The flattening cache
-    lookupFlatCache, extendFlatCache, newFlattenSkolem,            -- Flatten skolems
-    dischargeFunEq, pprKicked,
+    lookupFamAppInert, lookupFamAppCache, extendFamAppCache,
+    pprKicked,
 
-    -- Inert CFunEqCans
-    updInertFunEqs, findFunEq,
-    findFunEqsByTyCon,
+    -- Inert function equalities
+    findFunEq, findFunEqsByTyCon,
 
     instDFunType,                              -- Instantiation
 
     -- MetaTyVars
     newFlexiTcSTy, instFlexi, instFlexiX,
-    cloneMetaTyVar, demoteUnfilledFmv,
+    cloneMetaTyVar,
     tcInstSkolTyVarsX,
 
     TcLevel,
@@ -118,11 +118,13 @@ module GHC.Tc.Solver.Monad (
     getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
     matchFam, matchFamTcM,
     checkWellStagedDFun,
-    pprEq                                    -- Smaller utils, re-exported from TcM
+    pprEq,                                   -- Smaller utils, re-exported from TcM
                                              -- TODO (DV): these are only really used in the
                                              -- instance matcher in GHC.Tc.Solver. I am wondering
                                              -- if the whole instance matcher simply belongs
                                              -- here
+
+    breakTyVarCycle, flattenView
 ) where
 
 #include "HsVersions.h"
@@ -145,6 +147,7 @@ import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDict
 import GHC.Tc.Utils.TcType
 import GHC.Driver.Session
 import GHC.Core.Type
+import qualified GHC.Core.TyCo.Rep as Rep  -- this needs to be used only very locally
 import GHC.Core.Coercion
 import GHC.Core.Unify
 
@@ -172,9 +175,7 @@ import GHC.Tc.Types.Origin
 import GHC.Tc.Types.Constraint
 import GHC.Core.Predicate
 
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.DFM
+import GHC.Types.Unique.Set
 import GHC.Core.TyCon.Env
 import GHC.Data.Maybe
 
@@ -185,10 +186,13 @@ import Control.Monad
 import GHC.Utils.Monad
 import Data.IORef
 import Data.List ( partition, mapAccumL )
+import qualified Data.Semigroup as S
+import Data.List.NonEmpty ( NonEmpty(..), cons, toList, nonEmpty )
+import qualified Data.List.NonEmpty as NE
+import Control.Arrow ( first )
 
 #if defined(DEBUG)
 import GHC.Data.Graph.Directed
-import GHC.Types.Unique.Set
 #endif
 
 {-
@@ -210,7 +214,6 @@ consider using this depth for prioritization as well in the future.
 As a simple form of priority queue, our worklist separates out
 
 * equalities (wl_eqs); see Note [Prioritise equalities]
-* type-function equalities (wl_funeqs)
 * all the rest (wl_rest)
 
 Note [Prioritise equalities]
@@ -268,15 +271,13 @@ So we arrange to put these particular class constraints in the wl_eqs.
 
 -- See Note [WorkList priorities]
 data WorkList
-  = WL { wl_eqs     :: [Ct]  -- CTyEqCan, CDictCan, CIrredCan
+  = WL { wl_eqs     :: [Ct]  -- CEqCan, CDictCan, CIrredCan
                              -- Given, Wanted, and Derived
                        -- Contains both equality constraints and their
                        -- class-level variants (a~b) and (a~~b);
                        -- See Note [Prioritise equalities]
                        -- See Note [Prioritise class equalities]
 
-       , wl_funeqs  :: [Ct]
-
        , wl_rest    :: [Ct]
 
        , wl_implics :: Bag Implication  -- See Note [Residual implications]
@@ -284,37 +285,21 @@ data WorkList
 
 appendWorkList :: WorkList -> WorkList -> WorkList
 appendWorkList
-    (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1
+    (WL { wl_eqs = eqs1, wl_rest = rest1
         , wl_implics = implics1 })
-    (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2
+    (WL { wl_eqs = eqs2, wl_rest = rest2
         , wl_implics = implics2 })
    = WL { wl_eqs     = eqs1     ++ eqs2
-        , wl_funeqs  = funeqs1  ++ funeqs2
         , wl_rest    = rest1    ++ rest2
         , wl_implics = implics1 `unionBags`   implics2 }
 
 workListSize :: WorkList -> Int
-workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })
-  = length eqs + length funeqs + length rest
-
-workListWantedCount :: WorkList -> Int
--- Count the things we need to solve
--- excluding the insolubles (c.f. inert_count)
-workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest })
-  = count isWantedCt eqs + count is_wanted rest
-  where
-    is_wanted ct
-     | CIrredCan { cc_status = InsolubleCIS } <- ct
-     = False
-     | otherwise
-     = isWantedCt ct
+workListSize (WL { wl_eqs = eqs, wl_rest = rest })
+  = length eqs + length rest
 
 extendWorkListEq :: Ct -> WorkList -> WorkList
 extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }
 
-extendWorkListFunEq :: Ct -> WorkList -> WorkList
-extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl }
-
 extendWorkListNonEq :: Ct -> WorkList -> WorkList
 -- Extension by non equality
 extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }
@@ -330,11 +315,6 @@ extendWorkListCt :: Ct -> WorkList -> WorkList
 -- Agnostic
 extendWorkListCt ct wl
  = case classifyPredType (ctPred ct) of
-     EqPred NomEq ty1 _
-       | Just tc <- tcTyConAppTyCon_maybe ty1
-       , isTypeFamilyTyCon tc
-       -> extendWorkListFunEq ct wl
-
      EqPred {}
        -> extendWorkListEq ct wl
 
@@ -349,20 +329,16 @@ extendWorkListCts :: [Ct] -> WorkList -> WorkList
 extendWorkListCts cts wl = foldr extendWorkListCt wl cts
 
 isEmptyWorkList :: WorkList -> Bool
-isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs
-                    , wl_rest = rest, wl_implics = implics })
-  = null eqs && null rest && null funeqs && isEmptyBag implics
+isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })
+  = null eqs && null rest && isEmptyBag implics
 
 emptyWorkList :: WorkList
-emptyWorkList = WL { wl_eqs  = [], wl_rest = []
-                   , wl_funeqs = [], wl_implics = emptyBag }
+emptyWorkList = WL { wl_eqs  = [], wl_rest = [], wl_implics = emptyBag }
 
 selectWorkItem :: WorkList -> Maybe (Ct, WorkList)
 -- See Note [Prioritise equalities]
-selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs
-                      , wl_rest = rest })
+selectWorkItem wl@(WL { wl_eqs = eqs, wl_rest = rest })
   | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })
-  | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes })
   | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })
   | otherwise      = Nothing
 
@@ -386,13 +362,10 @@ selectNextWorkItem
 
 -- Pretty printing
 instance Outputable WorkList where
-  ppr (WL { wl_eqs = eqs, wl_funeqs = feqs
-          , wl_rest = rest, wl_implics = implics })
+  ppr (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })
    = text "WL" <+> (braces $
      vcat [ ppUnless (null eqs) $
             text "Eqs =" <+> vcat (map ppr eqs)
-          , ppUnless (null feqs) $
-            text "Funeqs =" <+> vcat (map ppr feqs)
           , ppUnless (null rest) $
             text "Non-eqs =" <+> vcat (map ppr rest)
           , ppUnless (isEmptyBag implics) $
@@ -413,30 +386,20 @@ data InertSet
               -- Canonical Given, Wanted, Derived
               -- Sometimes called "the inert set"
 
-       , inert_fsks :: [(TcTyVar, TcType)]
-              -- A list of (fsk, ty) pairs; we add one element when we flatten
-              -- a function application in a Given constraint, creating
-              -- a new fsk in newFlattenSkolem.  When leaving a nested scope,
-              -- unflattenGivens unifies fsk := ty
-              --
-              -- We could also get this info from inert_funeqs, filtered by
-              -- level, but it seems simpler and more direct to capture the
-              -- fsk as we generate them.
+       , inert_cycle_breakers :: [(TcTyVar, TcType)]
+              -- a list of CycleBreakerTv / original family applications
+              -- used to undo the cycle-breaking needed to handle
+              -- Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical
 
-       , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour)
-              -- See Note [Type family equations]
-              -- If    F tys :-> (co, rhs, flav),
-              -- then  co :: F tys ~ rhs
-              --       flav is [G] or [WD]
+       , inert_famapp_cache :: FunEqMap (TcCoercion, TcType)
+              -- Just a hash-cons cache for use when reducing family applications
+              -- only
               --
-              -- Just a hash-cons cache for use when flattening only
-              -- These include entirely un-processed goals, so don't use
-              -- them to solve a top-level goal, else you may end up solving
-              -- (w:F ty ~ a) by setting w:=w!  We just use the flat-cache
-              -- when allocating a new flatten-skolem.
-              -- Not necessarily inert wrt top-level equations (or inert_cans)
-
-              -- NB: An ExactFunEqMap -- this doesn't match via loose types!
+              -- If    F tys :-> (co, rhs, flav),
+              -- then  co :: rhs ~N F tys
+              -- all evidence is from instances or Givens; no coercion holes here
+              -- (We have no way of "kicking out" from the cache, so putting
+              --  wanteds here means we can end up solving a Wanted with itself. Bad)
 
        , inert_solved_dicts   :: DictMap CtEvidence
               -- All Wanteds, of form ev :: C t1 .. tn
@@ -446,10 +409,8 @@ data InertSet
 
 instance Outputable InertSet where
   ppr (IS { inert_cans = ics
-          , inert_fsks = ifsks
           , inert_solved_dicts = solved_dicts })
       = vcat [ ppr ics
-             , text "Inert fsks =" <+> ppr ifsks
              , ppUnless (null dicts) $
                text "Solved dicts =" <+> vcat (map ppr dicts) ]
          where
@@ -457,8 +418,7 @@ instance Outputable InertSet where
 
 emptyInertCans :: InertCans
 emptyInertCans
-  = IC { inert_count    = 0
-       , inert_eqs      = emptyDVarEnv
+  = IC { inert_eqs      = emptyDVarEnv
        , inert_dicts    = emptyDicts
        , inert_safehask = emptyDicts
        , inert_funeqs   = emptyFunEqs
@@ -467,10 +427,10 @@ emptyInertCans
 
 emptyInert :: InertSet
 emptyInert
-  = IS { inert_cans         = emptyInertCans
-       , inert_fsks         = []
-       , inert_flat_cache   = emptyExactFunEqs
-       , inert_solved_dicts = emptyDictMap }
+  = IS { inert_cans           = emptyInertCans
+       , inert_cycle_breakers = []
+       , inert_famapp_cache   = emptyFunEqs
+       , inert_solved_dicts   = emptyDictMap }
 
 
 {- Note [Solved dictionaries]
@@ -708,16 +668,14 @@ Result
 data InertCans   -- See Note [Detailed InertCans Invariants] for more
   = IC { inert_eqs :: InertEqs
               -- See Note [inert_eqs: the inert equalities]
-              -- All CTyEqCans; index is the LHS tyvar
+              -- All CEqCans with a TyVarLHS; index is the LHS tyvar
               -- Domain = skolems and untouchables; a touchable would be unified
 
-       , inert_funeqs :: FunEqMap Ct
-              -- All CFunEqCans; index is the whole family head type.
-              -- All Nominal (that's an invariant of all CFunEqCans)
+       , inert_funeqs :: FunEqMap EqualCtList
+              -- All CEqCans with a TyFamLHS; index is the whole family head type.
               -- LHS is fully rewritten (modulo eqCanRewrite constraints)
               --     wrt inert_eqs
               -- Can include all flavours, [G], [W], [WD], [D]
-              -- See Note [Type family equations]
 
        , inert_dicts :: DictMap Ct
               -- Dictionaries only
@@ -739,16 +697,38 @@ data InertCans   -- See Note [Detailed InertCans Invariants] for more
               -- Irreducible predicates that cannot be made canonical,
               --     and which don't interact with others (e.g.  (c a))
               -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])
-
-       , inert_count :: Int
-              -- Number of Wanted goals in
-              --     inert_eqs, inert_dicts, inert_safehask, inert_irreds
-              -- Does not include insolubles
-              -- When non-zero, keep trying to solve
        }
 
 type InertEqs    = DTyVarEnv EqualCtList
-type EqualCtList = [Ct]  -- See Note [EqualCtList invariants]
+
+newtype EqualCtList = EqualCtList (NonEmpty Ct)
+  deriving newtype Outputable
+  -- See Note [EqualCtList invariants]
+
+unitEqualCtList :: Ct -> EqualCtList
+unitEqualCtList ct = EqualCtList (ct :| [])
+
+addToEqualCtList :: Ct -> EqualCtList -> EqualCtList
+-- NB: This function maintains the "derived-before-wanted" invariant of EqualCtList,
+-- but not the others. See Note [EqualCtList invariants]
+addToEqualCtList ct (EqualCtList old_eqs)
+  | isWantedCt ct
+  , eq1 :| eqs <- old_eqs
+  = EqualCtList (eq1 :| ct : eqs)
+  | otherwise
+  = EqualCtList (ct `cons` old_eqs)
+
+filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList
+filterEqualCtList pred (EqualCtList cts)
+  = fmap EqualCtList (nonEmpty $ NE.filter pred cts)
+
+equalCtListToList :: EqualCtList -> [Ct]
+equalCtListToList (EqualCtList cts) = toList cts
+
+listToEqualCtList :: [Ct] -> Maybe EqualCtList
+-- NB: This does not maintain invariants other than having the EqualCtList be
+-- non-empty
+listToEqualCtList cts = EqualCtList <$> nonEmpty cts
 
 {- Note [Detailed InertCans Invariants]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -766,11 +746,11 @@ The InertCans represents a collection of constraints with the following properti
   * Given family or dictionary constraints don't mention touchable
     unification variables
 
-  * Non-CTyEqCan constraints are fully rewritten with respect
-    to the CTyEqCan equalities (modulo canRewrite of course;
+  * Non-CEqCan constraints are fully rewritten with respect
+    to the CEqCan equalities (modulo eqCanRewrite of course;
     eg a wanted cannot rewrite a given)
 
-  * CTyEqCan equalities: see Note [inert_eqs: the inert equalities]
+  * CEqCan equalities: see Note [inert_eqs: the inert equalities]
     Also see documentation in Constraint.Ct for a list of invariants
 
 Note [EqualCtList invariants]
@@ -787,42 +767,6 @@ From the fourth invariant it follows that the list is
 
 The Wanteds can't rewrite anything which is why we put them last
 
-Note [Type family equations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Type-family equations, CFunEqCans, of form (ev : F tys ~ ty),
-live in three places
-
-  * The work-list, of course
-
-  * The inert_funeqs are un-solved but fully processed, and in
-    the InertCans. They can be [G], [W], [WD], or [D].
-
-  * The inert_flat_cache.  This is used when flattening, to get maximal
-    sharing. Everything in the inert_flat_cache is [G] or [WD]
-
-    It contains lots of things that are still in the work-list.
-    E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the
-        work list.  Then we flatten w1, dumping (w3: G a ~ f1) in the work
-        list.  Now if we flatten w2 before we get to w3, we still want to
-        share that (G a).
-    Because it contains work-list things, DO NOT use the flat cache to solve
-    a top-level goal.  Eg in the above example we don't want to solve w3
-    using w3 itself!
-
-The CFunEqCan Ownership Invariant:
-
-  * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv
-    It "owns" that fsk/fmv, in the sense that:
-      - reducing a [W/WD] CFunEqCan fills in the fmv
-      - unflattening a [W/WD] CFunEqCan fills in the fmv
-      (in both cases unless an occurs-check would result)
-
-  * In contrast a [D] CFunEqCan does not "own" its fmv:
-      - reducing a [D] CFunEqCan does not fill in the fmv;
-        it just generates an equality
-      - unflattening ignores [D] CFunEqCans altogether
-
-
 Note [inert_eqs: the inert equalities]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Definition [Can-rewrite relation]
@@ -837,25 +781,25 @@ Lemma.  If f1 >= f then f1 >= f1
 Proof.  By property (R2), with f1=f2
 
 Definition [Generalised substitution]
-A "generalised substitution" S is a set of triples (a -f-> t), where
-  a is a type variable
+A "generalised substitution" S is a set of triples (t0 -f-> t), where
+  t0 is a type variable or an exactly-saturated type family application
+    (that is, t0 is a CanEqLHS)
   t is a type
   f is a flavour
 such that
-  (WF1) if (a -f1-> t1) in S
-           (a -f2-> t2) in S
-        then neither (f1 >= f2) nor (f2 >= f1) hold
-  (WF2) if (a -f-> t) is in S, then t /= a
+  (WF1) if (t0 -f1-> t1) in S
+           (t0' -f2-> t2) in S
+        then either not (f1 >= f2) or t0 does not appear within t0'
+  (WF2) if (t0 -f-> t) is in S, then t /= t0
 
 Definition [Applying a generalised substitution]
 If S is a generalised substitution
-   S(f,a) = t,  if (a -fs-> t) in S, and fs >= f
-          = a,  otherwise
-Application extends naturally to types S(f,t), modulo roles.
-See Note [Flavours with roles].
+   S(f,t0) = t,  if (t0 -fs-> t) in S, and fs >= f
+           = apply S to components of t0, otherwise
+See also Note [Flavours with roles].
 
-Theorem: S(f,a) is well defined as a function.
-Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S,
+Theorem: S(f,t0) is well defined as a function.
+Proof: Suppose (t0 -f1-> t1) and (t0 -f2-> t2) are both in S,
                and  f1 >= f and f2 >= f
        Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)
 
@@ -874,46 +818,47 @@ applying S(f,_) to t.
 
 ----------------------------------------------------------------
 Our main invariant:
-   the inert CTyEqCans should be an inert generalised substitution
+   the inert CEqCans should be an inert generalised substitution
 ----------------------------------------------------------------
 
 Note that inertness is not the same as idempotence.  To apply S to a
-type, you may have to apply it recursive.  But inertness does
+type, you may have to apply it recursively.  But inertness does
 guarantee that this recursive use will terminate.
 
 Note [Extending the inert equalities]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Main Theorem [Stability under extension]
    Suppose we have a "work item"
-       a -fw-> t
+       t0 -fw-> t
    and an inert generalised substitution S,
-   THEN the extended substitution T = S+(a -fw-> t)
+   THEN the extended substitution T = S+(t0 -fw-> t)
         is an inert generalised substitution
    PROVIDED
-      (T1) S(fw,a) = a     -- LHS of work-item is a fixpoint of S(fw,_)
-      (T2) S(fw,t) = t     -- RHS of work-item is a fixpoint of S(fw,_)
-      (T3) a not in t      -- No occurs check in the work item
+      (T1) S(fw,t0) = t0     -- LHS of work-item is a fixpoint of S(fw,_)
+      (T2) S(fw,t)  = t      -- RHS of work-item is a fixpoint of S(fw,_)
+      (T3) t0 not in t       -- No occurs check in the work item
 
-      AND, for every (b -fs-> s) in S:
+      AND, for every (t0' -fs-> s) in S:
            (K0) not (fw >= fs)
                 Reason: suppose we kick out (a -fs-> s),
-                        and add (a -fw-> t) to the inert set.
+                        and add (t0 -fw-> t) to the inert set.
                         The latter can't rewrite the former,
                         so the kick-out achieved nothing
 
-           OR { (K1) not (a = b)
+           OR { (K1) t0 is not rewritable in t0'. That is, t0 does not occur
+                     in t0' (except perhaps in a cast or coercion).
                      Reason: if fw >= fs, WF1 says we can't have both
-                             a -fw-> t  and  a -fs-> s
+                             t0 -fw-> t  and  F t0 -fs-> s
 
                 AND (K2): guarantees inertness of the new substitution
                     {  (K2a) not (fs >= fs)
                     OR (K2b) fs >= fw
-                    OR (K2d) a not in s }
+                    OR (K2d) t0 not in s }
 
                 AND (K3) See Note [K3: completeness of solving]
-                    { (K3a) If the role of fs is nominal: s /= a
+                    { (K3a) If the role of fs is nominal: s /= t0
                       (K3b) If the role of fs is representational:
-                            s is not of form (a t1 .. tn) } }
+                            s is not of form (t0 t1 .. tn) } }
 
 
 Conditions (T1-T3) are established by the canonicaliser
@@ -924,8 +869,8 @@ The idea is that
   with S(fw,_).
 
 * T3 is guaranteed by a simple occurs-check on the work item.
-  This is done during canonicalisation, in canEqTyVar; invariant
-  (TyEq:OC) of CTyEqCan.
+  This is done during canonicalisation, in canEqCanLHSFinish; invariant
+  (TyEq:OC) of CEqCan.
 
 * (K1-3) are the "kick-out" criteria.  (As stated, they are really the
   "keep" criteria.) If the current inert S contains a triple that does
@@ -950,10 +895,10 @@ The idea is that
   It's used to avoid even looking for constraint to kick out.
 
 * Lemma (L1): The conditions of the Main Theorem imply that there is no
-              (a -fs-> t) in S, s.t.  (fs >= fw).
+              (t0 -fs-> t) in S, s.t.  (fs >= fw).
   Proof. Suppose the contrary (fs >= fw).  Then because of (T1),
-  S(fw,a)=a.  But since fs>=fw, S(fw,a) = s, hence s=a.  But now we
-  have (a -fs-> a) in S, which contradicts (WF2).
+  S(fw,t0)=t0.  But since fs>=fw, S(fw,t0) = s, hence s=t0.  But now we
+  have (t0 -fs-> t0) in S, which contradicts (WF2).
 
 * The extended substitution satisfies (WF1) and (WF2)
   - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).
@@ -1044,7 +989,7 @@ now reduced to reflexivity.
 The solution here is to kick out representational inerts whenever the
 tyvar of a work item is "exposed", where exposed means being at the
 head of the top-level application chain (a t1 .. tn).  See
-TcType.isTyVarHead. This is encoded in (K3b).
+is_can_eq_lhs_head. This is encoded in (K3b).
 
 Beware: if we make this test succeed too often, we kick out too much,
 and the solver might loop.  Consider (#14363)
@@ -1082,14 +1027,14 @@ instance Outputable InertCans where
   ppr (IC { inert_eqs = eqs
           , inert_funeqs = funeqs, inert_dicts = dicts
           , inert_safehask = safehask, inert_irreds = irreds
-          , inert_insts = insts
-          , inert_count = count })
+          , inert_insts = insts })
+
     = braces $ vcat
       [ ppUnless (isEmptyDVarEnv eqs) $
         text "Equalities:"
-          <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs)
+          <+> pprCts (foldDVarEnv folder emptyCts eqs)
       , ppUnless (isEmptyTcAppMap funeqs) $
-        text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs)
+        text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts)
       , ppUnless (isEmptyTcAppMap dicts) $
         text "Dictionaries =" <+> pprCts (dictsToBag dicts)
       , ppUnless (isEmptyTcAppMap safehask) $
@@ -1098,8 +1043,9 @@ instance Outputable InertCans where
         text "Irreds =" <+> pprCts irreds
       , ppUnless (null insts) $
         text "Given instances =" <+> vcat (map ppr insts)
-      , text "Unsolved goals =" <+> int count
       ]
+    where
+      folder (EqualCtList eqs) rest = nonEmptyToBag eqs `andCts` rest
 
 {- *********************************************************************
 *                                                                      *
@@ -1115,21 +1061,13 @@ solving.  Here's a classic example (indexed-types/should_fail/T4093a)
 
     Ambiguity check for f: (Foo e ~ Maybe e) => Foo e
 
-    We get [G] Foo e ~ Maybe e
-           [W] Foo e ~ Foo ee      -- ee is a unification variable
-           [W] Foo ee ~ Maybe ee
+    We get [G] Foo e ~ Maybe e    (CEqCan)
+           [W] Foo ee ~ Foo e     (CEqCan)       -- ee is a unification variable
+           [W] Foo ee ~ Maybe ee  (CEqCan)
 
-    Flatten: [G] Foo e ~ fsk
-             [G] fsk ~ Maybe e   -- (A)
+    The first Wanted gets rewritten to
 
-             [W] Foo ee ~ fmv
-             [W] fmv ~ fsk       -- (B) From Foo e ~ Foo ee
-             [W] fmv ~ Maybe ee
-
-    --> rewrite (B) with (A)
-             [W] Foo ee ~ fmv
-             [W] fmv ~ Maybe e
-             [W] fmv ~ Maybe ee
+           [W] Foo ee ~ Maybe e
 
     But now we appear to be stuck, since we don't rewrite Wanteds with
     Wanteds.  This is silly because we can see that ee := e is the
@@ -1162,20 +1100,18 @@ More specifically, here's how it works (Oct 16):
   putting the latter into the work list (see maybeEmitShadow).
 
 In the example above, we get to the point where we are stuck:
-    [WD] Foo ee ~ fmv
-    [WD] fmv ~ Maybe e
-    [WD] fmv ~ Maybe ee
+    [WD] Foo ee ~ Foo e
+    [WD] Foo ee ~ Maybe ee
 
-But now when [WD] fmv ~ Maybe ee is about to be added, we'll
-split it into [W] and [D], since the inert [WD] fmv ~ Maybe e
+But now when [WD] Foo ee ~ Maybe ee is about to be added, we'll
+split it into [W] and [D], since the inert [WD] Foo ee ~ Foo e
 can rewrite it.  Then:
-    work item: [D] fmv ~ Maybe ee
-    inert:     [W] fmv ~ Maybe ee
-               [WD] fmv ~ Maybe e   -- (C)
-               [WD] Foo ee ~ fmv
+    work item: [D] Foo ee ~ Maybe ee
+    inert:     [W] Foo ee ~ Maybe ee
+               [WD] Foo ee ~ Maybe e
 
 See Note [Splitting WD constraints].  Now the work item is rewritten
-by (C) and we soon get ee := e.
+by the [WD] and we soon get ee := e.
 
 Additional notes:
 
@@ -1189,15 +1125,14 @@ Additional notes:
   * We also get Derived equalities from functional dependencies
     and type-function injectivity; see calls to unifyDerived.
 
-  * This splitting business applies to CFunEqCans too; and then
-    we do apply type-function reductions to the [D] CFunEqCan.
-    See Note [Reduction for Derived CFunEqCans]
-
   * It's worth having [WD] rather than just [W] and [D] because
     * efficiency: silly to process the same thing twice
-    * inert_funeqs, inert_dicts is a finite map keyed by
+    * inert_dicts is a finite map keyed by
       the type; it's inconvenient for it to map to TWO constraints
 
+Another example requiring Deriveds is in
+Note [Put touchable variables on the left] in GHC.Tc.Solver.Canonical.
+
 Note [Splitting WD constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We are about to add a [WD] constraint to the inert set; and we
@@ -1205,7 +1140,7 @@ know that the inert set has fully rewritten it.  Should we split
 it into [W] and [D], and put the [D] in the work list for further
 work?
 
-* CDictCan (C tys) or CFunEqCan (F tys ~ fsk):
+* CDictCan (C tys):
   Yes if the inert set could rewrite tys to make the class constraint,
   or type family, fire.  That is, yes if the inert_eqs intersects
   with the free vars of tys.  For this test we use
@@ -1213,8 +1148,8 @@ work?
   because rewriting the casts or coercions won't make the thing fire
   more often.
 
-* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'.
-  We need to check both 'a' and 'ty' against the inert set:
+* CEqCan (lhs ~ ty): Yes if the inert set could rewrite 'lhs' or 'ty'.
+  We need to check both 'lhs' and 'ty' against the inert set:
     - Inert set contains  [D] a ~ ty2
       Then we want to put [D] a ~ ty in the worklist, so we'll
       get [D] ty ~ ty2 with consequent good things
@@ -1245,22 +1180,17 @@ scenario:
 
   work item: [WD] a ~ beta
 
-This is heterogeneous, so we try flattening the kinds.
-
-  co :: F v ~ fmv
-  [WD] (a |> co) ~ beta
-
-This is still hetero, so we emit a kind equality and make the work item an
+This is heterogeneous, so we emit a kind equality and make the work item an
 inert Irred.
 
-  work item: [D] fmv ~ alpha
+  work item: [D] F v ~ alpha
   inert: [WD] (a |> co) ~ beta (CIrredCan)
 
 Can't make progress on the work item. Add to inert set. This kicks out the
 old inert, because a [D] can rewrite a [WD].
 
   work item: [WD] (a |> co) ~ beta
-  inert: [D] fmv ~ alpha (CTyEqCan)
+  inert: [D] F v ~ alpha (CEqCan)
 
 Can't make progress on this work item either (although GHC tries by
 decomposing the cast and reflattening... but that doesn't make a difference),
@@ -1268,25 +1198,24 @@ which is still hetero. Emit a new kind equality and add to inert set. But,
 critically, we split the Irred.
 
   work list:
-   [D] fmv ~ alpha (CTyEqCan)
+   [D] F v ~ alpha (CEqCan)
    [D] (a |> co) ~ beta (CIrred) -- this one was split off
   inert:
    [W] (a |> co) ~ beta
-   [D] fmv ~ alpha
+   [D] F v ~ alpha
 
 We quickly solve the first work item, as it's the same as an inert.
 
   work item: [D] (a |> co) ~ beta
   inert:
    [W] (a |> co) ~ beta
-   [D] fmv ~ alpha
+   [D] F v ~ alpha
 
 We decompose the cast, yielding
 
   [D] a ~ beta
 
-We then flatten the kinds. The lhs kind is F v, which flattens to fmv which
-then rewrites to alpha.
+We then flatten the kinds. The lhs kind is F v, which flattens to alpha.
 
   co' :: F v ~ alpha
   [D] (a |> co') ~ beta
@@ -1301,35 +1230,6 @@ If we don't split the Irreds, we loop. This is all dangerously subtle.
 
 This is triggered by test case typecheck/should_compile/SplitWD.
 
-Note [Examples of how Derived shadows helps completeness]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-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] UnF (F a) ~ a
-               [WD] UnF (F beta) ~ beta
-               [WD] F a ~ F beta
-  Flatten:
-      [G] g1: F a ~ fsk1         fsk1 := F a
-      [G] g2: UnF fsk1 ~ fsk2    fsk2 := UnF fsk1
-      [G] g3: fsk2 ~ a
-
-      [WD] w1: F beta ~ fmv1
-      [WD] w2: UnF fmv1 ~ fmv2
-      [WD] w3: fmv2 ~ beta
-      [WD] w4: fmv1 ~ fsk1   -- From F a ~ F beta using flat-cache
-                             -- and re-orient to put meta-var on left
-
-Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2
-React that with g2: [D] d2: fmv2 ~ fsk2
-React that with w3: [D] beta ~ fsk2
-            and g3: [D] beta ~ a -- Hooray beta := a
-And that is enough to solve everything
-
 Note [Add derived shadows only for Wanteds]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We only add shadows for Wanted constraints. That is, we have
@@ -1423,7 +1323,7 @@ maybeEmitShadow ics ct
   | let ev = ctEvidence ct
   , CtWanted { ctev_pred = pred, ctev_loc = loc
              , ctev_nosh = WDeriv } <- ev
-  , shouldSplitWD (inert_eqs ics) ct
+  , shouldSplitWD (inert_eqs ics) (inert_funeqs ics) ct
   = do { traceTcS "Emit derived shadow" (ppr ct)
        ; let derived_ev = CtDerived { ctev_pred = pred
                                     , ctev_loc  = loc }
@@ -1442,45 +1342,52 @@ maybeEmitShadow ics ct
   | otherwise
   = return ct
 
-shouldSplitWD :: InertEqs -> Ct -> Bool
+shouldSplitWD :: InertEqs -> FunEqMap EqualCtList -> Ct -> Bool
 -- Precondition: 'ct' is [WD], and is inert
 -- True <=> we should split ct ito [W] and [D] because
 --          the inert_eqs can make progress on the [D]
 -- See Note [Splitting WD constraints]
 
-shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys })
-  = should_split_match_args inert_eqs tys
-    -- We don't need to split if the tv is the RHS fsk
-
-shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys })
-  = should_split_match_args inert_eqs tys
+shouldSplitWD inert_eqs fun_eqs (CDictCan { cc_tyargs = tys })
+  = should_split_match_args inert_eqs fun_eqs tys
     -- NB True: ignore coercions
     -- See Note [Splitting WD constraints]
 
-shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty
-                                  , cc_eq_rel = eq_rel })
+shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_lhs = TyVarLHS tv, cc_rhs = ty
+                                        , cc_eq_rel = eq_rel })
   =  tv `elemDVarEnv` inert_eqs
-  || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty
+  || anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs) ty
   -- NB False: do not ignore casts and coercions
   -- See Note [Splitting WD constraints]
 
-shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev })
-  = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev)
+shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })
+  = anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)
+                          (ctEvPred ev)
+
+shouldSplitWD inert_eqs fun_eqs (CIrredCan { cc_ev = ev })
+  = anyRewritableCanEqLHS (ctEvEqRel ev) (canRewriteTv inert_eqs)
+                          (canRewriteTyFam fun_eqs) (ctEvPred ev)
 
-shouldSplitWD _ _ = False   -- No point in splitting otherwise
+shouldSplitWD _ _ _ = False   -- No point in splitting otherwise
 
-should_split_match_args :: InertEqs -> [TcType] -> Bool
--- True if the inert_eqs can rewrite anything in the argument
--- types, ignoring casts and coercions
-should_split_match_args inert_eqs tys
-  = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys
-    -- NB True: ignore casts coercions
+should_split_match_args :: InertEqs -> FunEqMap EqualCtList -> [TcType] -> Bool
+-- True if the inert_eqs can rewrite anything in the argument types
+should_split_match_args inert_eqs fun_eqs tys
+  = any (anyRewritableCanEqLHS NomEq (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)) tys
     -- See Note [Splitting WD constraints]
 
 canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool
 canRewriteTv inert_eqs eq_rel tv
-  | Just (ct : _) <- lookupDVarEnv inert_eqs tv
-  , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct
+  | Just (EqualCtList (ct :| _)) <- lookupDVarEnv inert_eqs tv
+  , CEqCan { cc_eq_rel = eq_rel1 } <- ct
+  = eq_rel1 `eqCanRewrite` eq_rel
+  | otherwise
+  = False
+
+canRewriteTyFam :: FunEqMap EqualCtList -> EqRel -> TyCon -> [Type] -> Bool
+canRewriteTyFam fun_eqs eq_rel tf args
+  | Just (EqualCtList (ct :| _)) <- findFunEq fun_eqs tf args
+  , CEqCan { cc_eq_rel = eq_rel1 } <- ct
   = eq_rel1 `eqCanRewrite` eq_rel
   | otherwise
   = False
@@ -1499,32 +1406,46 @@ isImprovable _                                = True
 
 addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs
 addTyEq old_eqs tv ct
-  = extendDVarEnv_C add_eq old_eqs tv [ct]
+  = extendDVarEnv_C add_eq old_eqs tv (unitEqualCtList ct)
   where
-    add_eq old_eqs _
-      | isWantedCt ct
-      , (eq1 : eqs) <- old_eqs
-      = eq1 : ct : eqs
-      | otherwise
-      = ct : old_eqs
+    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 $ unitEqualCtList ct
 
 foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b
 foldTyEqs k eqs z
-  = foldDVarEnv (\cts z -> foldr k z cts) z eqs
-
-findTyEqs :: InertCans -> TyVar -> EqualCtList
-findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` []
+  = foldDVarEnv (\(EqualCtList cts) z -> foldr k z cts) z eqs
+
+findTyEqs :: InertCans -> TyVar -> [Ct]
+findTyEqs icans tv = maybe [] id (fmap @Maybe equalCtListToList $
+                                  lookupDVarEnv (inert_eqs icans) tv)
+
+delEq :: InertCans -> CanEqLHS -> TcType -> InertCans
+delEq ic lhs 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)
 
-delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs
-delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv
-  where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1
-        isThisOne _                          = False
+    upd :: Maybe EqualCtList -> Maybe EqualCtList
+    upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list
+    upd Nothing           = Nothing
 
-lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType
-lookupInertTyVar ieqs tv
-  = case lookupDVarEnv ieqs tv of
-      Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs
-      _                                                        -> Nothing
+findEq :: InertCans -> CanEqLHS -> [Ct]
+findEq icans (TyVarLHS tv) = findTyEqs icans tv
+findEq icans (TyFamLHS fun_tc fun_args)
+  = maybe [] id (fmap @Maybe equalCtListToList $
+                 findFunEq (inert_funeqs icans) fun_tc fun_args)
 
 {- *********************************************************************
 *                                                                      *
@@ -1590,33 +1511,13 @@ When adding an equality to the inerts:
 
 * Note that unifying a:=ty, is like adding [G] a~ty; just use
   kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.
-
-Note [Kicking out CFunEqCan for fundeps]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider:
-   New:    [D] fmv1 ~ fmv2
-   Inert:  [W] F alpha ~ fmv1
-           [W] F beta  ~ fmv2
-
-where F is injective. The new (derived) equality certainly can't
-rewrite the inerts. But we *must* kick out the first one, to get:
-
-   New:   [W] F alpha ~ fmv1
-   Inert: [W] F beta ~ fmv2
-          [D] fmv1 ~ fmv2
-
-and now improvement will discover [D] alpha ~ beta. This is important;
-eg in #9587.
-
-So in kickOutRewritable we look at all the tyvars of the
-CFunEqCan, including the fsk.
 -}
 
-addInertCan :: Ct -> TcS ()  -- Constraints *other than* equalities
+addInertCan :: Ct -> TcS ()
 -- Precondition: item /is/ canonical
 -- See Note [Adding an equality to the InertCans]
 addInertCan ct
-  = do { traceTcS "insertInertCan {" $
+  = do { traceTcS "addInertCan {" $
          text "Trying to insert new inert item:" <+> ppr ct
 
        ; ics <- getInertCans
@@ -1627,58 +1528,59 @@ addInertCan ct
        ; traceTcS "addInertCan }" $ empty }
 
 maybeKickOut :: InertCans -> Ct -> TcS InertCans
--- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan
+-- For a CEqCan, kick out any inert that can be rewritten by the CEqCan
 maybeKickOut ics ct
-  | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct
-  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics
+  | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct
+  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics
        ; return ics' }
   | otherwise
   = return ics
 
 add_item :: InertCans -> Ct -> InertCans
-add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })
-  = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item }
+add_item ics item@(CEqCan { cc_lhs = TyFamLHS tc tys })
+  = ics { inert_funeqs = addCanFunEq (inert_funeqs ics) tc tys item }
 
-add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev })
-  = ics { inert_eqs   = addTyEq (inert_eqs ics) tv item
-        , inert_count = bumpUnsolvedCount ev (inert_count ics) }
+add_item ics item@(CEqCan { cc_lhs = TyVarLHS tv })
+  = ics { inert_eqs   = addTyEq (inert_eqs ics) tv item }
 
-add_item ics@(IC { inert_irreds = irreds, inert_count = count })
-         item@(CIrredCan { cc_ev = ev, cc_status = status })
-  = ics { inert_irreds = irreds `Bag.snocBag` item
-        , inert_count  = case status of
-                           InsolubleCIS -> count
-                           _            -> bumpUnsolvedCount ev count }
-                              -- inert_count does not include insolubles
+add_item ics@(IC { inert_irreds = irreds }) item@(CIrredCan {})
+  = ics { inert_irreds = irreds `Bag.snocBag` item }
 
-
-add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
-  = ics { inert_dicts = addDict (inert_dicts ics) cls tys item
-        , inert_count = bumpUnsolvedCount ev (inert_count ics) }
+add_item ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })
+  = ics { inert_dicts = addDict (inert_dicts ics) cls tys item }
 
 add_item _ item
   = pprPanic "upd_inert set: can't happen! Inserting " $
     ppr item   -- Can't be CNonCanonical because they only land in inert_irreds
 
-bumpUnsolvedCount :: CtEvidence -> Int -> Int
-bumpUnsolvedCount ev n | isWanted ev = n+1
-                       | otherwise   = n
-
-
 -----------------------------------------
 kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that
                                       -- is being added to the inert set
-                    -> TcTyVar        -- The new equality is tv ~ ty
-                    -> InertCans
-                    -> TcS (Int, InertCans)
-kickOutRewritable new_fr new_tv ics
-  = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics
+                   -> CanEqLHS        -- The new equality is lhs ~ ty
+                   -> InertCans
+                   -> TcS (Int, InertCans)
+kickOutRewritable new_fr new_lhs ics
+  = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_lhs ics
              n_kicked = workListSize kicked_out
 
        ; unless (n_kicked == 0) $
          do { updWorkListTcS (appendWorkList kicked_out)
+
+              -- The famapp-cache contains Given evidence from the inert set.
+              -- If we're kicking out Givens, we need to remove this evidence
+              -- from the cache, too.
+            ; let kicked_given_ev_vars =
+                    [ ev_var | ct <- wl_eqs kicked_out
+                             , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ]
+            ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&
+                   -- if this isn't true, no use looking through the constraints
+                    not (null kicked_given_ev_vars)) $
+              do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"
+                            (ppr kicked_given_ev_vars)
+                 ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) }
+
             ; csTraceTcS $
-              hang (text "Kick out, tv =" <+> ppr new_tv)
+              hang (text "Kick out, lhs =" <+> ppr new_lhs)
                  2 (vcat [ text "n-kicked =" <+> int n_kicked
                          , text "kicked_out =" <+> ppr kicked_out
                          , text "Residual inerts =" <+> ppr ics' ]) }
@@ -1687,18 +1589,17 @@ kickOutRewritable new_fr new_tv ics
 
 kick_out_rewritable :: CtFlavourRole  -- Flavour/role of the equality that
                                       -- is being added to the inert set
-                    -> TcTyVar        -- The new equality is tv ~ ty
+                    -> CanEqLHS       -- The new equality is lhs ~ ty
                     -> InertCans
                     -> (WorkList, InertCans)
 -- See Note [kickOutRewritable]
-kick_out_rewritable new_fr new_tv
+kick_out_rewritable new_fr new_lhs
                     ics@(IC { inert_eqs      = tv_eqs
                             , inert_dicts    = dictmap
                             , inert_safehask = safehask
                             , inert_funeqs   = funeqmap
                             , inert_irreds   = irreds
-                            , inert_insts    = old_insts
-                            , inert_count    = n })
+                            , inert_insts    = old_insts })
   | not (new_fr `eqMayRewriteFR` new_fr)
   = (emptyWorkList, ics)
         -- If new_fr can't rewrite itself, it can't rewrite
@@ -1714,25 +1615,24 @@ kick_out_rewritable new_fr new_tv
                        , inert_safehask = safehask   -- ??
                        , inert_funeqs   = feqs_in
                        , inert_irreds   = irs_in
-                       , inert_insts    = insts_in
-                       , inert_count    = n - workListWantedCount kicked_out }
+                       , inert_insts    = insts_in }
 
     kicked_out :: WorkList
     -- NB: use extendWorkList to ensure that kicked-out equalities get priority
     -- See Note [Prioritise equalities] (Kick-out).
     -- The irreds may include non-canonical (hetero-kinded) equality
-    -- constraints, which perhaps may have become soluble after new_tv
+    -- constraints, which perhaps may have become soluble after 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
-                                         , wl_funeqs = feqs_out })
+                          (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out })
                           ((dicts_out `andCts` irs_out)
                             `extendCtsList` insts_out)
 
-    (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs
-    (feqs_out,   feqs_in)   = partitionFunEqs  kick_out_ct funeqmap
-           -- See Note [Kicking out CFunEqCan for fundeps]
+    (tv_eqs_out, tv_eqs_in) = foldDVarEnv (kick_out_eqs extend_tv_eqs)
+                                          ([], emptyDVarEnv) tv_eqs
+    (feqs_out,   feqs_in)   = foldFunEqs  (kick_out_eqs extend_fun_eqs)
+                                          funeqmap ([], emptyFunEqs)
     (dicts_out,  dicts_in)  = partitionDicts   kick_out_ct dictmap
     (irs_out,    irs_in)    = partitionBag     kick_out_ct irreds
       -- Kick out even insolubles: See Note [Rewrite insolubles]
@@ -1757,46 +1657,80 @@ kick_out_rewritable new_fr new_tv
 
     (_, new_role) = new_fr
 
+    fr_tv_can_rewrite_ty :: TyVar -> EqRel -> Type -> Bool
+    fr_tv_can_rewrite_ty new_tv role ty
+      = anyRewritableTyVar True role can_rewrite ty
+                  -- True: ignore casts and coercions
+      where
+        can_rewrite :: EqRel -> TyVar -> Bool
+        can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv
+
+    fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool
+    fr_tf_can_rewrite_ty new_tf new_tf_args role ty
+      = anyRewritableTyFamApp role can_rewrite ty
+      where
+        can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool
+        can_rewrite old_role old_tf old_tf_args
+          = new_role `eqCanRewrite` old_role &&
+            tcEqTyConApps new_tf new_tf_args old_tf old_tf_args
+              -- it's possible for old_tf_args to have too many. This is fine;
+              -- we'll only check what we need to.
+
+    {-# INLINE fr_can_rewrite_ty #-}   -- perform the check here only once
     fr_can_rewrite_ty :: EqRel -> Type -> Bool
-    fr_can_rewrite_ty role ty = anyRewritableTyVar False role
-                                                   fr_can_rewrite_tv ty
-    fr_can_rewrite_tv :: EqRel -> TyVar -> Bool
-    fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role
-                             && tv == new_tv
+    fr_can_rewrite_ty = case new_lhs of
+      TyVarLHS new_tv             -> fr_tv_can_rewrite_ty new_tv
+      TyFamLHS new_tf new_tf_args -> fr_tf_can_rewrite_ty new_tf new_tf_args
 
     fr_may_rewrite :: CtFlavourRole -> Bool
     fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs
         -- Can the new item rewrite the inert item?
 
+    {-# INLINE kick_out_ct #-}   -- perform case on new_lhs here only once
     kick_out_ct :: Ct -> Bool
-    -- Kick it out if the new CTyEqCan can rewrite the inert one
+    -- Kick it out if the new CEqCan can rewrite the inert one
     -- See Note [kickOutRewritable]
-    kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct
-                   = fr_may_rewrite fs
-                   && fr_can_rewrite_ty role (ctPred ct)
-                  -- False: ignore casts and coercions
-                  -- NB: this includes the fsk of a CFunEqCan.  It can't
-                  --     actually be rewritten, but we need to kick it out
-                  --     so we get to take advantage of injectivity
-                  -- See Note [Kicking out CFunEqCan for fundeps]
-
-    kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList)
-                 -> ([Ct], DTyVarEnv EqualCtList)
-    kick_out_eqs eqs (acc_out, acc_in)
-      = (eqs_out ++ acc_out, case eqs_in of
-                               []      -> acc_in
-                               (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in)
+    kick_out_ct = case new_lhs of
+      TyVarLHS new_tv -> \ct -> let fs@(_,role) = ctFlavourRole ct in
+                                fr_may_rewrite fs
+                             && fr_tv_can_rewrite_ty new_tv role (ctPred ct)
+      TyFamLHS new_tf new_tf_args
+        -> \ct -> let fs@(_, role) = ctFlavourRole ct in
+                  fr_may_rewrite fs
+               && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct)
+
+    extend_tv_eqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs
+    extend_tv_eqs eqs (TyVarLHS tv) cts = extendDVarEnv eqs tv cts
+    extend_tv_eqs eqs other _cts = pprPanic "extend_tv_eqs" (ppr eqs $$ ppr other)
+
+    extend_fun_eqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList
+                   -> FunEqMap EqualCtList
+    extend_fun_eqs eqs (TyFamLHS fam_tc fam_args) cts
+      = insertTcApp eqs fam_tc fam_args cts
+    extend_fun_eqs eqs other _cts = pprPanic "extend_fun_eqs" (ppr eqs $$ ppr other)
+
+    kick_out_eqs :: (container -> CanEqLHS -> EqualCtList -> container)
+                 -> EqualCtList -> ([Ct], container)
+                 -> ([Ct], container)
+    kick_out_eqs extend eqs (acc_out, acc_in)
+      = (eqs_out `chkAppend` acc_out, case listToEqualCtList eqs_in of
+            Nothing -> acc_in
+            Just eqs_in_ecl@(EqualCtList (eq1 :| _))
+                    -> extend acc_in (cc_lhs eq1) eqs_in_ecl)
       where
-        (eqs_out, eqs_in) = partition kick_out_eq eqs
+        (eqs_out, eqs_in) = partition kick_out_eq (equalCtListToList eqs)
 
     -- Implements criteria K1-K3 in Note [Extending the inert equalities]
-    kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty
-                          , cc_ev = ev, cc_eq_rel = eq_rel })
+    kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty
+                        , cc_ev = ev, cc_eq_rel = eq_rel })
       | not (fr_may_rewrite fs)
       = False  -- Keep it in the inert set if the new thing can't rewrite it
 
       -- Below here (fr_may_rewrite fs) is True
-      | tv == new_tv              = True        -- (K1)
+      | fr_can_rewrite_ty eq_rel (canEqLHSType lhs) = True   -- (K1)
+         -- The above check redundantly checks the role & flavour,
+         -- but it's very convenient
+
       | kick_out_for_inertness    = True
       | kick_out_for_completeness = True
       | otherwise                 = False
@@ -1809,27 +1743,48 @@ kick_out_rewritable new_fr new_tv
             && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2d)
             -- (K2c) is guaranteed by the first guard of keep_eq
 
-        kick_out_for_completeness
+        kick_out_for_completeness  -- (K3) and Note [K3: completeness of solving]
           = case eq_rel of
-              NomEq  -> rhs_ty `eqType` mkTyVarTy new_tv
-              ReprEq -> isTyVarHead new_tv rhs_ty
+              NomEq  -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a)
+              ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty    -- (K3b)
 
     kick_out_eq ct = pprPanic "keep_eq" (ppr ct)
 
+    is_can_eq_lhs_head (TyVarLHS tv) = go
+      where
+        go (Rep.TyVarTy tv')   = tv == tv'
+        go (Rep.AppTy fun _)   = go fun
+        go (Rep.CastTy ty _)   = go ty
+        go (Rep.TyConApp {})   = False
+        go (Rep.LitTy {})      = False
+        go (Rep.ForAllTy {})   = False
+        go (Rep.FunTy {})      = False
+        go (Rep.CoercionTy {}) = False
+    is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go
+      where
+        go (Rep.TyVarTy {})       = False
+        go (Rep.AppTy {})         = False  -- no TyConApp to the left of an AppTy
+        go (Rep.CastTy ty _)      = go ty
+        go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args
+        go (Rep.LitTy {})         = False
+        go (Rep.ForAllTy {})      = False
+        go (Rep.FunTy {})         = False
+        go (Rep.CoercionTy {})    = False
+
 kickOutAfterUnification :: TcTyVar -> TcS Int
 kickOutAfterUnification new_tv
   = do { ics <- getInertCans
        ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)
-                                                 new_tv ics
+                                                 (TyVarLHS new_tv) ics
                      -- Given because the tv := xi is given; NomEq because
                      -- only nominal equalities are solved by unification
 
        ; setInertCans ics2
        ; return n_kicked }
 
--- See Wrinkle (2b) in Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical"
-kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()
-kickOutAfterFillingCoercionHole hole
+-- See Wrinkle (2a) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical
+kickOutAfterFillingCoercionHole :: CoercionHole -> Coercion -> TcS ()
+kickOutAfterFillingCoercionHole hole filled_co
   = do { ics <- getInertCans
        ; let (kicked_out, ics') = kick_out ics
              n_kicked           = workListSize kicked_out
@@ -1844,44 +1799,50 @@ kickOutAfterFillingCoercionHole hole
 
        ; setInertCans ics' }
   where
+    holes_of_co = coercionHolesOfCo filled_co
+
     kick_out :: InertCans -> (WorkList, InertCans)
     kick_out ics@(IC { inert_irreds = irreds })
-      = let (to_kick, to_keep) = partitionBag kick_ct irreds
+      = let (to_kick, to_keep) = partitionBagWith kick_ct irreds
 
             kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList
             ics'       = ics { inert_irreds = to_keep }
         in
         (kicked_out, ics')
 
-    kick_ct :: Ct -> Bool
-    -- This is not particularly efficient. Ways to do better:
-    --  1) Have a custom function that looks for a coercion hole and returns a Bool
-    --  2) Keep co-hole-blocked constraints in a separate part of the inert set,
-    --     keyed by their co-hole. (Is it possible for more than one co-hole to be
-    --     in a constraint? I doubt it.)
-    kick_ct (CIrredCan { cc_ev = ev, cc_status = BlockedCIS })
-      = coHoleCoVar hole `elemVarSet` tyCoVarsOfType (ctEvPred ev)
-    kick_ct _other = False
+    kick_ct :: Ct -> Either Ct Ct
+         -- Left: kick out; Right: keep. But even if we keep, we may need
+         -- to update the set of blocking holes
+    kick_ct ct@(CIrredCan { cc_status = BlockedCIS holes })
+      | hole `elementOfUniqSet` holes
+      = let new_holes = holes `delOneFromUniqSet` hole
+                              `unionUniqSets` holes_of_co
+            updated_ct = ct { cc_status = BlockedCIS new_holes }
+        in
+        if isEmptyUniqSet new_holes
+        then Left updated_ct
+        else Right updated_ct
+    kick_ct other = Right other
 
 {- Note [kickOutRewritable]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 See also Note [inert_eqs: the inert equalities].
 
-When we add a new inert equality (a ~N ty) to the inert set,
+When we add a new inert equality (lhs ~N ty) to the inert set,
 we must kick out any inert items that could be rewritten by the
 new equality, to maintain the inert-set invariants.
 
   - We want to kick out an existing inert constraint if
     a) the new constraint can rewrite the inert one
-    b) 'a' is free in the inert constraint (so that it *will*)
+    b) 'lhs' is free in the inert constraint (so that it *will*)
        rewrite it if we kick it out.
 
-    For (b) we use tyCoVarsOfCt, which returns the type variables /and
-    the kind variables/ that are directly visible in the type. Hence
+    For (b) we use anyRewritableCanLHS, which examines the types /and
+    kinds/ that are directly visible in the type. Hence
     we will have exposed all the rewriting we care about to make the
     most precise kinds visible for matching classes etc. No need to
     kick out constraints that mention type variables whose kinds
-    contain this variable!
+    contain this LHS!
 
   - A Derived equality can kick out [D] constraints in inert_eqs,
     inert_dicts, inert_irreds etc.
@@ -1999,11 +1960,6 @@ updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()
 updInertSafehask upd_fn
   = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }
 
-updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()
--- Modify the inert set with the supplied function
-updInertFunEqs upd_fn
-  = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) }
-
 updInertIrreds :: (Cts -> Cts) -> TcS ()
 -- Modify the inert set with the supplied function
 updInertIrreds upd_fn
@@ -2019,13 +1975,13 @@ getInertInsols = do { inert <- getInertCans
                     ; return (filterBag insolubleEqCt (inert_irreds inert)) }
 
 getInertGivens :: TcS [Ct]
--- Returns the Given constraints in the inert set,
--- with type functions *not* unflattened
+-- Returns the Given constraints in the inert set
 getInertGivens
   = do { inerts <- getInertCans
        ; let all_cts = foldDicts (:) (inert_dicts inerts)
-                     $ foldFunEqs (:) (inert_funeqs inerts)
-                     $ concat (dVarEnvElts (inert_eqs inerts))
+                     $ foldFunEqs (\ecl out -> equalCtListToList ecl ++ out)
+                                  (inert_funeqs inerts)
+                     $ concatMap equalCtListToList (dVarEnvElts (inert_eqs inerts))
        ; return (filter isGivenCt all_cts) }
 
 getPendingGivenScs :: TcS [Ct]
@@ -2077,9 +2033,7 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
     -- Note [The superclass story] in GHC.Tc.Solver.Canonical
 
 getUnsolvedInerts :: TcS ( Bag Implication
-                         , Cts     -- Tyvar eqs: a ~ ty
-                         , Cts     -- Fun eqs:   F a ~ ty
-                         , Cts )   -- All others
+                         , Cts )   -- All simple constraints
 -- Return all the unsolved [Wanted] or [Derived] constraints
 --
 -- Post-condition: the returned simple constraints are all fully zonked
@@ -2093,7 +2047,7 @@ getUnsolvedInerts
            } <- getInertCans
 
       ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts
-            unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts
+            unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts
             unsolved_irreds  = Bag.filterBag is_unsolved irreds
             unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts
             unsolved_others  = unsolved_irreds `unionBags` unsolved_dicts
@@ -2106,78 +2060,80 @@ getUnsolvedInerts
              , text "others =" <+> ppr unsolved_others
              , text "implics =" <+> ppr implics ]
 
-      ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, unsolved_others) }
+      ; return ( implics, unsolved_tv_eqs `unionBags`
+                          unsolved_fun_eqs `unionBags`
+                          unsolved_others) }
   where
     add_if_unsolved :: Ct -> Cts -> Cts
     add_if_unsolved ct cts | is_unsolved 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
+                                             (equalCtListToList new_cts)
+
     is_unsolved ct = not (isGivenCt ct)   -- Wanted or Derived
 
-    -- For CFunEqCans we ignore the Derived ones, and keep
-    -- only the Wanteds for flattening.  The Derived ones
-    -- share a unification variable with the corresponding
-    -- Wanted, so we definitely don't want to participate
-    -- in unflattening
-    -- See Note [Type family equations]
-    add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts
-                         | otherwise     = cts
-
-isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool
--- True if (a ~N ty) is in the inert set, in either Given or Wanted
-isInInertEqs eqs tv rhs
-  = case lookupDVarEnv eqs tv of
-      Nothing  -> False
-      Just cts -> any (same_pred rhs) cts
-  where
-    same_pred rhs ct
-      | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct
-      , NomEq <- eq_rel
-      , rhs `eqType` rhs2 = True
-      | otherwise         = False
-
-getNoGivenEqs :: TcLevel          -- TcLevel of this implication
-               -> [TcTyVar]       -- Skolems of this implication
-               -> TcS ( Bool      -- True <=> definitely no residual given equalities
-                      , Cts )     -- Insoluble equalities arising from givens
+getHasGivenEqs :: TcLevel           -- TcLevel of this implication
+               -> TcS ( HasGivenEqs -- are there Given equalities?
+                      , Cts )       -- Insoluble equalities arising from givens
 -- See Note [When does an implication have given equalities?]
-getNoGivenEqs tclvl skol_tvs
-  = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds })
+getHasGivenEqs tclvl
+  = do { inerts@(IC { inert_eqs = ieqs, inert_funeqs = funeqs, inert_irreds = irreds })
               <- getInertCans
-       ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds
-                          || anyDVarEnv eqs_given_here ieqs
+       ; let has_given_eqs = foldMap check_local_given_ct irreds
+                        S.<> foldMap (lift_equal_ct_list check_local_given_tv_eq) ieqs
+                        S.<> foldMapFunEqs (lift_equal_ct_list check_local_given_ct) funeqs
              insols = filterBag insolubleEqCt irreds
                       -- Specifically includes ones that originated in some
                       -- outer context but were refined to an insoluble by
                       -- a local equality; so do /not/ add ct_given_here.
 
-       ; traceTcS "getNoGivenEqs" $
-         vcat [ if has_given_eqs then text "May have given equalities"
-                                 else text "No given equalities"
-              , text "Skols:" <+> ppr skol_tvs
+       ; traceTcS "getHasGivenEqs" $
+         vcat [ text "has_given_eqs:" <+> ppr has_given_eqs
               , text "Inerts:" <+> ppr inerts
               , text "Insols:" <+> ppr insols]
-       ; return (not has_given_eqs, insols) }
+       ; return (has_given_eqs, insols) }
   where
-    eqs_given_here :: EqualCtList -> Bool
-    eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })]
-                              -- Givens are always a singleton
-      = not (skolem_bound_here tv) && ct_given_here ct
-    eqs_given_here _ = False
+    check_local_given_ct :: Ct -> HasGivenEqs
+    check_local_given_ct ct
+      | given_here ev = if mentions_outer_var ev then MaybeGivenEqs else LocalGivenEqs
+      | otherwise     = NoGivenEqs
+      where
+        ev = ctEvidence ct
+
+    lift_equal_ct_list :: (Ct -> HasGivenEqs) -> EqualCtList -> HasGivenEqs
+    -- returns NoGivenEqs for non-singleton lists, as Given lists are always
+    -- singletons
+    lift_equal_ct_list check (EqualCtList (ct :| [])) = check ct
+    lift_equal_ct_list _     _                        = NoGivenEqs
+
+    check_local_given_tv_eq :: Ct -> HasGivenEqs
+    check_local_given_tv_eq (CEqCan { cc_lhs = TyVarLHS tv, cc_ev = ev})
+      | given_here ev
+      = if is_outer_var tv then MaybeGivenEqs else NoGivenEqs
+        -- See Note [Let-bound skolems]
+      | otherwise
+      = NoGivenEqs
+    check_local_given_tv_eq other_ct = check_local_given_ct other_ct
 
-    ct_given_here :: Ct -> Bool
+    given_here :: CtEvidence -> Bool
     -- True for a Given bound by the current implication,
     -- i.e. the current level
-    ct_given_here ct =  isGiven ev
-                     && tclvl == ctLocLevel (ctEvLoc ev)
-        where
-          ev = ctEvidence ct
+    given_here ev =  isGiven ev
+                  && tclvl == ctLocLevel (ctEvLoc ev)
+
+    mentions_outer_var :: CtEvidence -> Bool
+    mentions_outer_var = anyFreeVarsOfType is_outer_var . ctEvPred
 
-    skol_tv_set = mkVarSet skol_tvs
-    skolem_bound_here tv -- See Note [Let-bound skolems]
-      = case tcTyVarDetails tv of
-          SkolemTv {} -> tv `elemVarSet` skol_tv_set
-          _           -> False
+    is_outer_var :: TyCoVar -> Bool
+    is_outer_var tv
+            -- NB: a meta-tv alpha[3] may end up unifying with skolem b[2],
+            -- so treat it as an "outer" var, even at level 3.
+            -- This will become redundant after fixing #18929.
+      | isTyVar tv = isTouchableMetaTyVar tclvl tv ||
+                     tclvl `strictlyDeeperThan` tcTyVarLevel tv
+      | otherwise  = False
 
 -- | Returns Given constraints that might,
 -- potentially, match the given pred. This is used when checking to see if a
@@ -2208,10 +2164,26 @@ matchableGivens loc_w pred_w (IS { inert_cans = inert_cans })
       = False
 
 mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool
+-- See Note [What might match later?]
 mightMatchLater given_pred given_loc wanted_pred wanted_loc
-  =  not (prohibitedSuperClassSolve given_loc wanted_loc)
-  && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred])
+  | prohibitedSuperClassSolve given_loc wanted_loc
+  = False
+
+  | SurelyApart <- tcUnifyTysFG bind_meta_tv [flattened_given] [flattened_wanted]
+  = False
+
+  | otherwise
+  = True   -- safe answer
   where
+    in_scope  = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred]
+
+    -- NB: flatten both at the same time, so that we can share mappings
+    -- from type family applications to variables, and also to guarantee
+    -- that the fresh variables are really fresh between the given and
+    -- the wanted.
+    ([flattened_given, flattened_wanted], var_mapping)
+      = flattenTysX in_scope [given_pred, wanted_pred]
+
     bind_meta_tv :: TcTyVar -> BindFlag
     -- Any meta tyvar may be unified later, so we treat it as
     -- bindable when unifying with givens. That ensures that we
@@ -2219,9 +2191,17 @@ mightMatchLater given_pred given_loc wanted_pred wanted_loc
     -- something that matches the 'given', until demonstrated
     -- otherwise.  More info in Note [Instance and Given overlap]
     -- in GHC.Tc.Solver.Interact
-    bind_meta_tv tv | isMetaTyVar tv
-                    , not (isFskTyVar tv) = BindMe
-                    | otherwise           = Skolem
+    bind_meta_tv tv | is_meta_tv tv = BindMe
+
+                    | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv
+                    , anyFreeVarsOfTypes is_meta_tv fam_args
+                    = BindMe
+
+                    | otherwise     = Skolem
+
+     -- CycleBreakerTvs really stands for a type family application in
+     -- a given; these won't contain touchable meta-variables
+    is_meta_tv = isMetaTyVar <&&> not . isCycleBreakerTyVar
 
 prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool
 -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
@@ -2239,6 +2219,55 @@ because it is a candidate for floating out of this implication.  We
 only float equalities with a meta-tyvar on the left, so we only pull
 those out here.
 
+Note [What might match later?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must determine whether a Given might later match a Wanted. We
+definitely need to account for the possibility that any metavariable
+in the Wanted might be arbitrarily instantiated. We do *not* want
+to allow skolems in the Given to be instantiated. But what about
+type family applications? (Examples are below the explanation.)
+
+To allow flexibility in how type family applications unify we use
+the Core flattener. See
+Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.
+This is *distinct* from the flattener in GHC.Tc.Solver.Flatten.
+The Core flattener replaces all type family applications with
+fresh variables. The next question: should we allow these fresh
+variables in the domain of a unifying substitution?
+
+A type family application that mentions only skolems is settled: any
+skolems would have been rewritten w.r.t. Givens by now. These type
+family applications match only themselves. A type family application
+that mentions metavariables, on the other hand, can match anything.
+So, if the original type family application contains a metavariable,
+we use BindMe to tell the unifier to allow it in the substitution.
+On the other hand, a type family application with only skolems is
+considered rigid.
+
+Examples:
+    [G] C a
+    [W] C alpha
+  This easily might match later.
+
+    [G] C a
+    [W] C (F alpha)
+  This might match later, too, but we need to flatten the (F alpha)
+  to a fresh variable so that the unifier can connect the two.
+
+    [G] C (F alpha)
+    [W] C a
+  This also might match later. Again, we will need to flatten to
+  find this out. (Surprised about a metavariable in a Given? See
+  #18929.)
+
+    [G] C (F a)
+    [W] C a
+  This won't match later. We're not going to get new Givens that
+  can inform the F a, and so this is a no-go.
+
+This treatment fixes #18910 and is tested in
+typecheck/should_compile/InstanceGivenOverlap{,2}
+
 Note [When does an implication have given equalities?]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider an implication
@@ -2269,22 +2298,39 @@ are some wrinkles:
       beta => ...blah...
    If we still don't know what beta is, we conservatively treat it as potentially
    becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs.
+   Note that we can't really know what's in an irred, so any irred is considered
+   a potential equality.
+
+ * What about something like forall a b. a ~ F b => [W] c ~ X y z? That Given
+   cannot affect the Wanted, because the Given is entirely *local*: it mentions
+   only skolems bound in the very same implication. Such equalities need not
+   prevent floating. (Test case typecheck/should_compile/LocalGivenEqs has a
+   real-life motivating example, with some detailed commentary.) These
+   equalities are noted with LocalGivenEqs: they do not prevent floating, but
+   they also are allowed to show up in error messages. See
+   Note [Suppress redundant givens during error reporting] in GHC.Tc.Errors.
+   The difference between what stops floating and what is suppressed from
+   error messages is why we need three options for HasGivenEqs.
+
+   There is also a simpler case that triggers this behaviour:
+
+     data T where
+       MkT :: F a ~ G b => a -> b -> T
 
- * When flattening givens, we generate Given equalities like
-     <F [a]> : F [a] ~ f,
-   with Refl evidence, and we *don't* want those to count as an equality
-   in the givens!  After all, the entire flattening business is just an
-   internal matter, and the evidence does not mention any of the 'givens'
-   of this implication.  So we do not treat inert_funeqs as a 'given equality'.
+     f (MkT _ _) = True
+
+   Because of this behaviour around local equality givens, we can infer the
+   type of f. This is typecheck/should_compile/LocalGivenEqs2.
 
  * See Note [Let-bound skolems] for another wrinkle
 
- * We do *not* need to worry about representational equalities, because
-   these do not affect the ability to float constraints.
+ * We need not look at the equality relation involved (nominal vs representational),
+   because representational equalities can still imply nominal ones. For example,
+   if (G a ~R G b) and G's argument's role is nominal, then we can deduce a ~N b.
 
 Note [Let-bound skolems]
 ~~~~~~~~~~~~~~~~~~~~~~~~
-If   * the inert set contains a canonical Given CTyEqCan (a ~ ty)
+If   * the inert set contains a canonical Given CEqCan (a ~ ty)
 and  * 'a' is a skolem bound in this very implication,
 
 then:
@@ -2296,8 +2342,7 @@ a) The Given is pretty much a let-binding, like
    and hence can be ignored by has_given_eqs
 
 b) 'a' will have been completely substituted out in the inert set,
-   so we can safely discard it.  Notably, it doesn't need to be
-   returned as part of 'fsks'
+   so we can safely discard it.
 
 For an example, see #9211.
 
@@ -2343,32 +2388,25 @@ removeInertCt is ct =
     CDictCan  { cc_class = cl, cc_tyargs = tys } ->
       is { inert_dicts = delDict (inert_dicts is) cl tys }
 
-    CFunEqCan { cc_fun  = tf,  cc_tyargs = tys } ->
-      is { inert_funeqs = delFunEq (inert_funeqs is) tf tys }
-
-    CTyEqCan  { cc_tyvar = x,  cc_rhs    = ty } ->
-      is { inert_eqs    = delTyEq (inert_eqs is) x ty }
+    CEqCan    { cc_lhs  = lhs, cc_rhs = rhs } -> delEq is lhs rhs
 
     CQuantCan {}     -> panic "removeInertCt: CQuantCan"
     CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"
     CNonCanonical {} -> panic "removeInertCt: CNonCanonical"
 
-lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))
-lookupFlatCache fam_tc tys
-  = do { IS { inert_flat_cache = flat_cache
-            , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts
-       ; return (firstJusts [lookup_inerts inert_funeqs,
-                             lookup_flats flat_cache]) }
+-- | Looks up a family application in the inerts; returned coercion
+-- is oriented input ~ output
+lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavourRole))
+lookupFamAppInert fam_tc tys
+  = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts
+       ; return (lookup_inerts inert_funeqs) }
   where
     lookup_inerts inert_funeqs
-      | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk })
-           <- findFunEq inert_funeqs fam_tc tys
-      = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev)
+      | Just (EqualCtList (CEqCan { cc_ev = ctev, cc_rhs = rhs } :| _))
+          <- findFunEq inert_funeqs fam_tc tys
+      = Just (ctEvCoercion ctev, rhs, ctEvFlavourRole ctev)
       | otherwise = Nothing
 
-    lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys
-
-
 lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
 -- Is this exact predicate type cached in the solved or canonicals of the InertSet?
 lookupInInerts loc pty
@@ -2394,6 +2432,40 @@ lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys
       Just ev -> Just ev
       _       -> Nothing
 
+---------------------------
+lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))
+lookupFamAppCache fam_tc tys
+  = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts
+       ; case findFunEq famapp_cache fam_tc tys of
+           result@(Just (co, ty)) ->
+             do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)
+                                                    , ppr ty
+                                                    , ppr co ])
+                ; return result }
+           Nothing -> return Nothing }
+
+extendFamAppCache :: TyCon -> [Type] -> (TcCoercion, TcType) -> TcS ()
+-- NB: co :: rhs ~ F tys, to match expectations of flattener
+extendFamAppCache tc xi_args stuff@(_, ty)
+  = do { dflags <- getDynFlags
+       ; when (gopt Opt_FamAppCache dflags) $
+    do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args
+                                            , ppr ty ])
+            -- 'co' can be bottom, in the case of derived items
+       ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->
+            is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }
+
+-- Remove entries from the cache whose evidence mentions variables in the
+-- supplied set
+dropFromFamAppCache :: VarSet -> TcS ()
+dropFromFamAppCache varset
+  = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts
+       ; let filtered = filterTcAppMap check famapp_cache
+       ; setTcSInerts $ inerts { inert_famapp_cache = filtered } }
+  where
+    check :: (TcCoercion, TcType) -> Bool
+    check (co, _) = not (anyFreeVarsOfCo (`elemVarSet` varset) co)
+
 {- *********************************************************************
 *                                                                      *
                    Irreds
@@ -2413,7 +2485,7 @@ foldIrreds k irreds z = foldr k z irreds
 Note [Use loose types in inert set]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Whenever we are looking up an inert dictionary (CDictCan) or function
-equality (CFunEqCan), we use a TcAppMap, which uses the Unique of the
+equality (CEqCan), we use a TcAppMap, which uses the Unique of the
 class/type family tycon and then a trie which maps the arguments. This
 trie does *not* need to match the kinds of the arguments; this Note
 explains why.
@@ -2433,54 +2505,56 @@ looking at kinds would be harmless.
 
 -}
 
-type TcAppMap a = UniqDFM Unique (ListMap LooseTypeMap a)
+type TcAppMap a = DTyConEnv (ListMap LooseTypeMap a)
     -- Indexed by tycon then the arg types, using "loose" matching, where
     -- we don't require kind equality. This allows, for example, (a |> co)
     -- to match (a).
     -- See Note [Use loose types in inert set]
     -- Used for types and classes; hence UniqDFM
-    -- See Note [foldTM determinism] for why we use UniqDFM here
+    -- See Note [foldTM determinism] in GHC.Data.TrieMap for why we use DTyConEnv here
 
 isEmptyTcAppMap :: TcAppMap a -> Bool
-isEmptyTcAppMap m = isNullUDFM m
+isEmptyTcAppMap m = isEmptyDTyConEnv m
 
 emptyTcAppMap :: TcAppMap a
-emptyTcAppMap = emptyUDFM
+emptyTcAppMap = emptyDTyConEnv
 
-findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a
-findTcApp m u tys = do { tys_map <- lookupUDFM m u
-                       ; lookupTM tys tys_map }
+findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a
+findTcApp m tc tys = do { tys_map <- lookupDTyConEnv m tc
+                        ; lookupTM tys tys_map }
 
-delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a
-delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls
+delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a
+delTcApp m tc tys = adjustDTyConEnv (deleteTM tys) m tc
 
-insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a
-insertTcApp m cls tys ct = alterUDFM alter_tm m cls
+insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a
+insertTcApp m tc tys ct = alterDTyConEnv alter_tm m tc
   where
     alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))
 
--- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b
--- mapTcApp f = mapUDFM (mapTM f)
+alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> (Maybe a -> Maybe a) -> TcAppMap a
+alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc
+  where
+    alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)
+    alter_tm m_elt = Just (alterTM tys upd (m_elt `orElse` emptyTM))
 
-filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct
-filterTcAppMap f m
-  = mapUDFM do_tm m
+filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a
+filterTcAppMap f m = mapMaybeDTyConEnv one_tycon m
   where
-    do_tm tm = foldTM insert_mb tm emptyTM
-    insert_mb ct tm
-       | f ct      = insertTM tys ct tm
-       | otherwise = tm
-       where
-         tys = case ct of
-                CFunEqCan { cc_tyargs = tys } -> tys
-                CDictCan  { cc_tyargs = tys } -> tys
-                _ -> pprPanic "filterTcAppMap" (ppr ct)
+    one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)
+    one_tycon tm
+      | isEmptyTM filtered_tm = Nothing
+      | otherwise             = Just filtered_tm
+      where
+        filtered_tm = filterTM f tm
 
 tcAppMapToBag :: TcAppMap a -> Bag a
 tcAppMapToBag m = foldTcAppMap consBag m emptyBag
 
 foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b
-foldTcAppMap k m z = foldUDFM (foldTM k) z m
+foldTcAppMap k m z = foldDTyConEnv (foldTM k) z m
+
+foldMapTcAppMap :: Monoid m => (a -> m) -> TcAppMap a -> m
+foldMapTcAppMap f = foldMap (foldMap f)
 
 
 {- *********************************************************************
@@ -2547,22 +2621,22 @@ findDict m loc cls tys
   = Nothing             -- See Note [Solving CallStack constraints]
 
   | otherwise
-  = findTcApp m (getUnique cls) tys
+  = findTcApp m (classTyCon cls) tys
 
 findDictsByClass :: DictMap a -> Class -> Bag a
 findDictsByClass m cls
-  | Just tm <- lookupUDFM_Directly m (getUnique cls) = foldTM consBag tm emptyBag
-  | otherwise                  = emptyBag
+  | Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag
+  | otherwise                                     = emptyBag
 
 delDict :: DictMap a -> Class -> [Type] -> DictMap a
-delDict m cls tys = delTcApp m (getUnique cls) tys
+delDict m cls tys = delTcApp m (classTyCon cls) tys
 
 addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a
-addDict m cls tys item = insertTcApp m (getUnique cls) tys item
+addDict m cls tys item = insertTcApp m (classTyCon cls) tys item
 
 addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
 addDictsByClass m cls items
-  = addToUDFM_Directly m (getUnique cls) (foldr add emptyTM items)
+  = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items)
   where
     add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm
     add ct _ = pprPanic "addDictsByClass" (ppr ct)
@@ -2601,10 +2675,7 @@ emptyFunEqs :: TcAppMap a
 emptyFunEqs = emptyTcAppMap
 
 findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a
-findFunEq m tc tys = findTcApp m (getUnique tc) tys
-
-funEqsToBag :: FunEqMap a -> Bag a
-funEqsToBag m = foldTcAppMap consBag m emptyBag
+findFunEq m tc tys = findTcApp m tc tys
 
 findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
 -- Get inert function equation constraints that have the given tycon
@@ -2612,50 +2683,17 @@ findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
 -- We use this to check for derived interactions with built-in type-function
 -- constructors.
 findFunEqsByTyCon m tc
-  | Just tm <- lookupUDFM m (getUnique tc) = foldTM (:) tm []
-  | otherwise                              = []
+  | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm []
+  | otherwise                       = []
 
 foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b
 foldFunEqs = foldTcAppMap
 
--- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b
--- mapFunEqs = mapTcApp
-
--- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct
--- filterFunEqs = filterTcAppMap
+foldMapFunEqs :: Monoid m => (a -> m) -> FunEqMap a -> m
+foldMapFunEqs = foldMapTcAppMap
 
 insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
-insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val
-
-partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct)
--- Optimise for the case where the predicate is false
--- partitionFunEqs is called only from kick-out, and kick-out usually
--- kicks out very few equalities, so we want to optimise for that case
-partitionFunEqs f m = (yeses, foldr del m yeses)
-  where
-    yeses = foldTcAppMap k m []
-    k ct yeses | f ct      = ct : yeses
-               | otherwise = yeses
-    del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m
-        = delFunEq m tc tys
-    del ct _ = pprPanic "partitionFunEqs" (ppr ct)
-
-delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a
-delFunEq m tc tys = delTcApp m (getUnique tc) tys
-
-------------------------------
-type ExactFunEqMap a = TyConEnv (ListMap TypeMap a)
-
-emptyExactFunEqs :: ExactFunEqMap a
-emptyExactFunEqs = emptyUFM
-
-findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a
-findExactFunEq m tc tys = do { tys_map <- lookupUFM m tc
-                             ; lookupTM tys tys_map }
-
-insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a
-insertExactFunEq m tc tys val = alterUFM alter_tm m tc
-  where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM))
+insertFunEq m tc tys val = insertTcApp m tc tys val
 
 {-
 ************************************************************************
@@ -2691,7 +2729,7 @@ data TcSEnv
       tcs_inerts    :: IORef InertSet, -- Current inert set
 
       -- The main work-list and the flattening worklist
-      -- See Note [Work list priorities] and
+      -- See Note [WorkList priorities] and
       tcs_worklist  :: IORef WorkList -- Current worklist
     }
 
@@ -2796,7 +2834,7 @@ runTcS :: TcS a                -- What to run
        -> TcM (a, EvBindMap)
 runTcS tcs
   = do { ev_binds_var <- TcM.newTcEvBinds
-       ; res <- runTcSWithEvBinds ev_binds_var True tcs
+       ; res <- runTcSWithEvBinds ev_binds_var tcs
        ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
        ; return (res, ev_binds) }
 -- | This variant of 'runTcS' will keep solving, even when only Deriveds
@@ -2805,32 +2843,38 @@ runTcS tcs
 runTcSDeriveds :: TcS a -> TcM a
 runTcSDeriveds tcs
   = do { ev_binds_var <- TcM.newTcEvBinds
-       ; runTcSWithEvBinds ev_binds_var True tcs }
+       ; runTcSWithEvBinds ev_binds_var tcs }
 
 -- | This can deal only with equality constraints.
 runTcSEqualities :: TcS a -> TcM a
 runTcSEqualities thing_inside
   = do { ev_binds_var <- TcM.newNoTcEvBinds
-       ; runTcSWithEvBinds ev_binds_var True thing_inside }
+       ; runTcSWithEvBinds ev_binds_var thing_inside }
 
 -- | A variant of 'runTcS' that takes and returns an 'InertSet' for
--- later resumption of the 'TcS' session. Crucially, it doesn't
--- 'unflattenGivens' when done.
+-- later resumption of the 'TcS' session.
 runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)
 runTcSInerts inerts tcs = do
   ev_binds_var <- TcM.newTcEvBinds
-  -- Passing False here to prohibit unflattening
-  runTcSWithEvBinds ev_binds_var False $ do
+  runTcSWithEvBinds' False ev_binds_var $ do
     setTcSInerts inerts
     a <- tcs
     new_inerts <- getTcSInerts
     return (a, new_inerts)
 
 runTcSWithEvBinds :: EvBindsVar
-                  -> Bool       -- ^ Unflatten types afterwards? Don't if you want to reuse the InertSet.
                   -> TcS a
                   -> TcM a
-runTcSWithEvBinds ev_binds_var unflatten tcs
+runTcSWithEvBinds = runTcSWithEvBinds' True
+
+runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?
+                           -- Don't if you want to reuse the InertSet.
+                           -- See also Note [Type variable cycles in Givens]
+                           -- in GHC.Tc.Solver.Canonical
+                   -> EvBindsVar
+                   -> TcS a
+                   -> TcM a
+runTcSWithEvBinds' restore_cycles ev_binds_var tcs
   = do { unified_var <- TcM.newTcRef 0
        ; step_count <- TcM.newTcRef 0
        ; inert_var <- TcM.newTcRef emptyInert
@@ -2848,7 +2892,9 @@ runTcSWithEvBinds ev_binds_var unflatten tcs
        ; when (count > 0) $
          csTraceTcM $ return (text "Constraint solver steps =" <+> int count)
 
-       ; when unflatten $ unflattenGivens inert_var
+       ; when restore_cycles $
+         do { inert_set <- TcM.readTcRef inert_var
+            ; restoreTyVarCycles inert_set }
 
 #if defined(DEBUG)
        ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
@@ -2899,10 +2945,8 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
                    , tcs_count         = count
                    } ->
     do { inerts <- TcM.readTcRef old_inert_var
-       ; let nest_inert = emptyInert
-                            { inert_cans = inert_cans inerts
-                            , inert_solved_dicts = inert_solved_dicts inerts }
-                              -- See Note [Do not inherit the flat cache]
+       ; let nest_inert = inerts { inert_cycle_breakers = [] }
+                 -- all other InertSet fields are inherited
        ; new_inert_var <- TcM.newTcRef nest_inert
        ; new_wl_var    <- TcM.newTcRef emptyWorkList
        ; let nest_env = TcSEnv { tcs_ev_binds      = ref
@@ -2913,7 +2957,8 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
        ; res <- TcM.setTcLevel inner_tclvl $
                 thing_inside nest_env
 
-       ; unflattenGivens new_inert_var
+       ; out_inert_set <- TcM.readTcRef new_inert_var
+       ; restoreTyVarCycles out_inert_set
 
 #if defined(DEBUG)
        -- Perform a check that the thing_inside did not cause cycles
@@ -2922,22 +2967,10 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
 #endif
        ; return res }
 
-{- Note [Do not inherit the flat cache]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not want to inherit the flat cache when processing nested
-implications.  Consider
-   a ~ F b, forall c. b~Int => blah
-If we have F b ~ fsk in the flat-cache, and we push that into the
-nested implication, we might miss that F b can be rewritten to F Int,
-and hence perhaps solve it.  Moreover, the fsk from outside is
-flattened out after solving the outer level, but and we don't
-do that flattening recursively.
--}
-
 nestTcS ::  TcS a -> TcS a
 -- Use the current untouchables, augmenting the current
 -- evidence bindings, and solved dictionaries
--- But have no effect on the InertCans, or on the inert_flat_cache
+-- But have no effect on the InertCans, or on the inert_famapp_cache
 -- (we want to inherit the latter from processing the Givens)
 nestTcS (TcS thing_inside)
   = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->
@@ -3224,143 +3257,7 @@ zonkWC wc = wrapTcS (TcM.zonkWC wc)
 zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar
 zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)
 
-{- *********************************************************************
-*                                                                      *
-*                Flatten skolems                                       *
-*                                                                      *
-********************************************************************* -}
-
-newFlattenSkolem :: CtFlavour -> CtLoc
-                 -> TyCon -> [TcType]                    -- F xis
-                 -> TcS (CtEvidence, Coercion, TcTyVar)  -- [G/WD] x:: F xis ~ fsk
-newFlattenSkolem flav loc tc xis
-  = do { stuff@(ev, co, fsk) <- new_skolem
-       ; let fsk_ty = mkTyVarTy fsk
-       ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev)
-       ; return stuff }
-  where
-    fam_ty = mkTyConApp tc xis
-
-    new_skolem
-      | Given <- flav
-      = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty)
-
-           -- Extend the inert_fsks list, for use by unflattenGivens
-           ; updInertTcS $ \is -> is { inert_fsks = (fsk, fam_ty) : inert_fsks is }
-
-           -- Construct the Refl evidence
-           ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk)
-                 co   = mkNomReflCo fam_ty
-           ; ev  <- newGivenEvVar loc (pred, evCoercion co)
-           ; return (ev, co, fsk) }
-
-      | otherwise  -- Generate a [WD] for both Wanted and Derived
-                   -- See Note [No Derived CFunEqCans]
-      = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty)
-              -- See (2a) in "GHC.Tc.Solver.Canonical"
-              -- Note [Equalities with incompatible kinds]
-           ; (ev, hole_co) <- newWantedEq_SI NoBlockSubst WDeriv loc Nominal
-                                             fam_ty (mkTyVarTy fmv)
-           ; return (ev, hole_co, fmv) }
-
-----------------------------
-unflattenGivens :: IORef InertSet -> TcM ()
--- Unflatten all the fsks created by flattening types in Given
--- constraints. We must be sure to do this, else we end up with
--- flatten-skolems buried in any residual Wanteds
---
--- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv)
---     is filled in. Nothing else does so.
---
--- It's here (rather than in GHC.Tc.Solver.Flatten) because the Right Places
--- to call it are in runTcSWithEvBinds/nestImplicTcS, where it
--- is nicely paired with the creation an empty inert_fsks list.
-unflattenGivens inert_var
- = do { inerts <- TcM.readTcRef inert_var
-       ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts))
-       ; mapM_ flatten_one (inert_fsks inerts) }
-  where
-    flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty
-
-----------------------------
-extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS ()
-extendFlatCache tc xi_args stuff@(_, ty, fl)
-  | isGivenOrWDeriv fl  -- Maintain the invariant that inert_flat_cache
-                        -- only has [G] and [WD] CFunEqCans
-  = do { dflags <- getDynFlags
-       ; when (gopt Opt_FlatCache dflags) $
-    do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args
-                                          , ppr fl, ppr ty ])
-            -- 'co' can be bottom, in the case of derived items
-       ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) ->
-            is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } }
-
-  | otherwise
-  = return ()
-
-----------------------------
-unflattenFmv :: TcTyVar -> TcType -> TcS ()
--- Fill a flatten-meta-var, simply by unifying it.
--- This does NOT count as a unification in tcs_unified.
-unflattenFmv tv ty
-  = ASSERT2( isMetaTyVar tv, ppr tv )
-    TcS $ \ _ ->
-    do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty)
-       ; TcM.writeMetaTyVar tv ty }
-
 ----------------------------
-demoteUnfilledFmv :: TcTyVar -> TcS ()
--- If a flatten-meta-var is still un-filled,
--- turn it into an ordinary meta-var
-demoteUnfilledFmv fmv
-  = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv
-                 ; unless is_filled $
-                   do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv)
-                      ; TcM.writeMetaTyVar fmv tv_ty } }
-
------------------------------
-dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()
--- (dischargeFunEq tv co ty)
---     Preconditions
---       - ev :: F tys ~ tv   is a CFunEqCan
---       - tv is a FlatMetaTv of FlatSkolTv
---       - co :: F tys ~ xi
---       - fmv/fsk `notElem` xi
---       - fmv not filled (for Wanteds)
---       - xi is flattened (and obeys Note [Almost function-free] in GHC.Tc.Types)
---
--- Then for [W] or [WD], we actually fill in the fmv:
---      set fmv := xi,
---      set ev  := co
---      kick out any inert things that are now rewritable
---
--- For [D], we instead emit an equality that must ultimately hold
---      [D] xi ~ fmv
---      Does not evaluate 'co' if 'ev' is Derived
---
--- For [G], emit this equality
---     [G] (sym ev; co) :: fsk ~ xi
-
--- See GHC.Tc.Solver.Flatten Note [The flattening story],
--- especially "Ownership of fsk/fmv"
-dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi
-  = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co  )
-       ; emitWorkNC [new_ev] }
-  where
-    new_pred = mkPrimEqPred (mkTyVarTy fsk) xi
-    new_co   = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co
-
-dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi
-  = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi )
-    do { setWantedEvTerm dest (evCoercion co)
-       ; unflattenFmv fmv xi
-       ; n_kicked <- kickOutAfterUnification fmv
-       ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) }
-
-dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi
-  = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv)
-              -- FunEqs are always at Nominal role
-
 pprKicked :: Int -> SDoc
 pprKicked 0 = empty
 pprKicked n = parens (int n <+> text "kicked out")
@@ -3486,7 +3383,7 @@ Yuk!
 fillCoercionHole :: CoercionHole -> Coercion -> TcS ()
 fillCoercionHole hole co
   = do { wrapTcS $ TcM.fillCoercionHole hole co
-       ; kickOutAfterFillingCoercionHole hole }
+       ; kickOutAfterFillingCoercionHole hole co }
 
 setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()
 setEvBindIfWanted ev tm
@@ -3533,13 +3430,13 @@ emitNewWantedEq loc role ty1 ty2
 -- | Make a new equality CtEvidence
 newWantedEq :: CtLoc -> Role -> TcType -> TcType
             -> TcS (CtEvidence, Coercion)
-newWantedEq = newWantedEq_SI YesBlockSubst WDeriv
+newWantedEq = newWantedEq_SI WDeriv
 
-newWantedEq_SI :: BlockSubstFlag -> ShadowInfo -> CtLoc -> Role
+newWantedEq_SI :: ShadowInfo -> CtLoc -> Role
                -> TcType -> TcType
                -> TcS (CtEvidence, Coercion)
-newWantedEq_SI blocker si loc role ty1 ty2
-  = do { hole <- wrapTcS $ TcM.newCoercionHole blocker pty
+newWantedEq_SI si loc role ty1 ty2
+  = do { hole <- wrapTcS $ TcM.newCoercionHole pty
        ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)
        ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
                            , ctev_nosh = si
@@ -3585,7 +3482,7 @@ newWanted = newWanted_SI WDeriv
 newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew
 newWanted_SI si loc pty
   | Just (role, ty1, ty2) <- getEqPredTys_maybe pty
-  = Fresh . fst <$> newWantedEq_SI YesBlockSubst si loc role ty1 ty2
+  = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2
   | otherwise
   = newWantedEvVar_SI si loc pty
 
@@ -3632,8 +3529,8 @@ checkReductionDepth loc ty
          solverDepthErrorTcS loc ty }
 
 matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType))
--- Given (F tys) return (ty, co), where co :: F tys ~N ty
-matchFam tycon args = wrapTcS $ matchFamTcM tycon args
+-- Given (F tys) return (ty, co), where co :: ty ~N F tys
+matchFam tycon args = fmap (fmap (first mkTcSymCo)) $ wrapTcS $ matchFamTcM tycon args
 
 matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType))
 -- Given (F tys) return (ty, co), where co :: F tys ~N ty
@@ -3662,3 +3559,71 @@ from which we get the implication
    (forall a. t1 ~ t2)
 See GHC.Tc.Solver.Monad.deferTcSForAllEq
 -}
+
+{-
+************************************************************************
+*                                                                      *
+              Breaking type variable cycles
+*                                                                      *
+************************************************************************
+-}
+
+-- | Replace all type family applications in the RHS with fresh variables,
+-- emitting givens that relate the type family application to the variable.
+-- See Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical.
+breakTyVarCycle :: CtLoc
+                -> TcType      -- the RHS
+                -> TcS TcType  -- new RHS that doesn't have any type families
+-- This could be considerably more efficient. See Detail (5) of Note.
+breakTyVarCycle loc = go
+  where
+    go ty | Just ty' <- flattenView ty = go ty'
+    go (Rep.TyConApp tc tys)
+      | isTypeFamilyTyCon tc
+      = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys
+                 fun_app                = mkTyConApp tc fun_args
+                 fun_app_kind           = tcTypeKind fun_app
+           ; new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind)
+           ; let new_ty     = mkTyVarTy new_tv
+                 given_pred = mkHeteroPrimEqPred fun_app_kind fun_app_kind
+                                                 fun_app new_ty
+                 given_term = evCoercion $ mkNomReflCo new_ty  -- See Detail (4) of Note
+           ; new_given <- newGivenEvVar loc (given_pred, given_term)
+           ; traceTcS "breakTyVarCycle replacing type family" (ppr new_given)
+           ; emitWorkNC [new_given]
+           ; updInertTcS $ \is ->
+               is { inert_cycle_breakers = (new_tv, fun_app) :
+                                           inert_cycle_breakers is }
+           ; extra_args' <- mapM go extra_args
+           ; return (mkAppTys new_ty extra_args') }
+              -- Worried that this substitution will change kinds?
+              -- See Detail (3) of Note
+
+      | otherwise
+      = mkTyConApp tc <$> mapM go tys
+
+    go (Rep.AppTy ty1 ty2)       = mkAppTy <$> go ty1 <*> go ty2
+    go (Rep.FunTy vis w arg res) = mkFunTy vis <$> go w <*> go arg <*> go res
+    go (Rep.CastTy ty co)        = mkCastTy <$> go ty <*> pure co
+
+    go ty@(Rep.TyVarTy {})    = return ty
+    go ty@(Rep.LitTy {})      = return ty
+    go ty@(Rep.ForAllTy {})   = return ty  -- See Detail (1) of Note
+    go ty@(Rep.CoercionTy {}) = return ty  -- See Detail (2) of Note
+
+-- | Fill in CycleBreakerTvs with the variables they stand for.
+-- See Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical.
+restoreTyVarCycles :: InertSet -> TcM ()
+restoreTyVarCycles is
+  = forM_ (inert_cycle_breakers is) $ \ (cycle_breaker_tv, orig_ty) ->
+    TcM.writeMetaTyVar cycle_breaker_tv orig_ty
+
+-- Unwrap a type synonym only when either:
+--   The type synonym is forgetful, or
+--   the type synonym mentions a type family in its expansion
+-- See Note [Flattening synonyms] in GHC.Tc.Solver.Flatten.
+flattenView :: TcType -> Maybe TcType
+flattenView ty@(Rep.TyConApp tc _)
+  | isForgetfulSynTyCon tc || (isTypeSynonymTyCon tc && not (isFamFreeTyCon tc))
+  = tcView ty
+flattenView _other = Nothing
diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs
index 308569ace0995b5afc4f218304afa22b1a3987c6..05fd70c6747275a0b63ce8d979f4c610c6efa6a6 100644
--- a/compiler/GHC/Tc/Types/Constraint.hs
+++ b/compiler/GHC/Tc/Types/Constraint.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, MultiWayIf #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
@@ -9,12 +9,12 @@ module GHC.Tc.Types.Constraint (
         QCInst(..), isPendingScInst,
 
         -- Canonical constraints
-        Xi, Ct(..), Cts, CtIrredStatus(..), emptyCts, andCts, andManyCts, pprCts,
+        Xi, Ct(..), Cts, CtIrredStatus(..), HoleSet,
+        emptyCts, andCts, andManyCts, pprCts,
         singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
-        isEmptyCts, isCTyEqCan, isCFunEqCan,
+        isEmptyCts,
         isPendingScDict, superClassesMightHelp, getPendingWantedScs,
-        isCDictCan_Maybe, isCFunEqCan_maybe,
-        isCNonCanonical, isWantedCt, isDerivedCt, isGivenCt,
+        isWantedCt, isDerivedCt, isGivenCt,
         isUserTypeErrorCt, getUserTypeErrorMsg,
         ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,
         ctEvId, mkTcEqPredLikeEv,
@@ -25,6 +25,9 @@ module GHC.Tc.Types.Constraint (
         tyCoVarsOfCt, tyCoVarsOfCts,
         tyCoVarsOfCtList, tyCoVarsOfCtsList,
 
+        CanEqLHS(..), canEqLHS_maybe, canEqLHSKind, canEqLHSType,
+        eqCanEqLHS,
+
         Hole(..), HoleSort(..), isOutOfScopeHole,
 
         WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
@@ -37,6 +40,7 @@ module GHC.Tc.Types.Constraint (
 
         Implication(..), implicationPrototype, checkTelescopeSkol,
         ImplicStatus(..), isInsolubleStatus, isSolvedStatus,
+        HasGivenEqs(..),
         SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,
         bumpSubGoalDepth, subGoalDepthExceeded,
         CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin,
@@ -48,7 +52,7 @@ module GHC.Tc.Types.Constraint (
         -- CtEvidence
         CtEvidence(..), TcEvDest(..),
         mkKindLoc, toKindLoc, mkGivenLoc,
-        isWanted, isGiven, isDerived, isGivenOrWDeriv,
+        isWanted, isGiven, isDerived,
         ctEvRole,
 
         wrapType,
@@ -57,7 +61,6 @@ module GHC.Tc.Types.Constraint (
         CtFlavourRole, ctEvFlavourRole, ctFlavourRole,
         eqCanRewrite, eqCanRewriteFR, eqMayRewriteFR,
         eqCanDischargeFR,
-        funEqCanDischarge, funEqCanDischargeF,
 
         -- Pretty printing
         pprEvVarTheta,
@@ -100,6 +103,7 @@ import GHC.Utils.Misc
 import GHC.Utils.Panic
 
 import Control.Monad ( msum )
+import qualified Data.Semigroup ( (<>) )
 
 {-
 ************************************************************************
@@ -109,28 +113,54 @@ import Control.Monad ( msum )
 *   These are the constraints the low-level simplifier works with      *
 *                                                                      *
 ************************************************************************
--}
 
--- The syntax of xi (ξ) types:
--- xi ::= a | T xis | xis -> xis | ... | forall a. tau
--- Two important notes:
---      (i) No type families, unless we are under a ForAll
---      (ii) Note that xi types can contain unexpanded type synonyms;
---           however, the (transitive) expansions of those type synonyms
---           will not contain any type functions, unless we are under a ForAll.
--- We enforce the structure of Xi types when we flatten (GHC.Tc.Solver.Canonical)
+Note [CEqCan occurs check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+A CEqCan relates a CanEqLHS (a type variable or type family applications) on
+its left to an arbitrary type on its right. It is used for rewriting, in the
+flattener. Because it is used for rewriting, it would be disastrous if the RHS
+were to mention the LHS: this would cause a loop in rewriting.
+
+We thus perform an occurs-check. There is, of course, some subtlety:
+
+* For type variables, the occurs-check looks deeply. This is because
+  a CEqCan over a meta-variable is also used to inform unification,
+  in GHC.Tc.Solver.Interact.solveByUnification. If the LHS appears
+  anywhere, at all, in the RHS, unification will create an infinite
+  structure, which is bad.
+
+* For type family applications, the occurs-check is shallow; it looks
+  only in places where we might rewrite. (Specifically, it does not
+  look in kinds or coercions.) An occurrence of the LHS in, say, an
+  RHS coercion is OK, as we do not rewrite in coercions. No loop to
+  be found.
+
+  You might also worry about the possibility that a type family
+  application LHS doesn't exactly appear in the RHS, but something
+  that reduces to the LHS does. Yet that can't happen: the RHS is
+  already inert, with all type family redexes reduced. So a simple
+  syntactic check is just fine.
+
+The occurs check is performed in GHC.Tc.Utils.Unify.checkTypeEq.
 
-type Xi = Type       -- In many comments, "xi" ranges over Xi
+-}
+
+-- | A 'Xi'-type is one that has been fully rewritten with respect
+-- to the inert set; that is, it has been flattened by the algorithm
+-- in GHC.Tc.Solver.Flatten. (Historical note: 'Xi', for years and years,
+-- meant that a type was type-family-free. It does *not* mean this
+-- any more.)
+type Xi = TcType
 
 type Cts = Bag Ct
 
 data Ct
   -- Atomic canonical constraints
-  = CDictCan {  -- e.g.  Num xi
+  = CDictCan {  -- e.g.  Num ty
       cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]
 
       cc_class  :: Class,
-      cc_tyargs :: [Xi],   -- cc_tyargs are function-free, hence Xi
+      cc_tyargs :: [Xi],   -- cc_tyargs are rewritten w.r.t. inerts, so Xi
 
       cc_pend_sc :: Bool   -- See Note [The superclass story] in GHC.Tc.Solver.Canonical
                            -- True <=> (a) cc_class has superclasses
@@ -144,8 +174,7 @@ data Ct
 
         -- For the might-be-soluble case, the ctev_pred of the evidence is
         -- of form   (tv xi1 xi2 ... xin)   with a tyvar at the head
-        --      or   (tv1 ~ ty2)   where the CTyEqCan  kind invariant (TyEq:K) fails
-        --      or   (F tys ~ ty)  where the CFunEqCan kind invariant fails
+        --      or   (lhs1 ~ ty2)  where the CEqCan    kind invariant (TyEq:K) fails
         -- See Note [CIrredCan constraints]
 
         -- The definitely-insoluble case is for things like
@@ -153,50 +182,32 @@ data Ct
         --    a ~ [a]         occurs check
     }
 
-  | CTyEqCan {  -- tv ~ rhs
+  | CEqCan {  -- CanEqLHS ~ rhs
        -- Invariants:
        --   * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad
-       --   * (TyEq:OC) tv not in deep tvs(rhs)   (occurs check)
-       --   * (TyEq:F) If tv is a TauTv, then rhs has no foralls
+       --   * 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) tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant]
-       --   * (TyEq:AFF) rhs (perhaps under the one cast) is *almost function-free*,
-       --       See Note [Almost function-free]
+       --   * (TyEq:K) tcTypeKind lhs `tcEqKind` tcTypeKind rhs; Note [Ct kind invariant]
        --   * (TyEq:N) If the equality is representational, rhs has no top-level newtype
-       --     See Note [No top-level newtypes on RHS of representational
-       --     equalities] in GHC.Tc.Solver.Canonical
-       --   * (TyEq:TV) If rhs (perhaps under the cast) is also a tv, then it is oriented
+       --     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
-       --     See "GHC.Tc.Solver.Canonical" Note [Canonical orientation for tyvar/tyvar equality constraints]
-       --   * (TyEq:H) The RHS has no blocking coercion holes. See "GHC.Tc.Solver.Canonical"
+       --     Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify
+       --   * (TyEq:H) The RHS has no blocking coercion holes. See GHC.Tc.Solver.Canonical
        --     Note [Equalities with incompatible kinds], wrinkle (2)
       cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]
-      cc_tyvar  :: TcTyVar,
-      cc_rhs    :: TcType,     -- Not necessarily function-free (hence not Xi)
-                               -- See invariants above
+      cc_lhs    :: CanEqLHS,
+      cc_rhs    :: Xi,         -- See invariants above
 
       cc_eq_rel :: EqRel       -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev
     }
 
-  | CFunEqCan {  -- F xis ~ fsk
-       -- Invariants:
-       --   * isTypeFamilyTyCon cc_fun
-       --   * tcTypeKind (F xis) = tyVarKind fsk; Note [Ct kind invariant]
-       --   * always Nominal role
-      cc_ev     :: CtEvidence,  -- See Note [Ct/evidence invariant]
-      cc_fun    :: TyCon,       -- A type function
-
-      cc_tyargs :: [Xi],        -- cc_tyargs are function-free (hence Xi)
-        -- Either under-saturated or exactly saturated
-        --    *never* over-saturated (because if so
-        --    we should have decomposed)
-
-      cc_fsk    :: TcTyVar  -- [G]  always a FlatSkolTv
-                            -- [W], [WD], or [D] always a FlatMetaTv
-        -- See Note [The flattening story] in GHC.Tc.Solver.Flatten
-    }
-
   | CNonCanonical {        -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad
       cc_ev  :: CtEvidence
     }
@@ -206,6 +217,18 @@ data Ct
       --     look like this, with the payload in an
       --     auxiliary type
 
+------------
+-- | A 'CanEqLHS' is a type that can appear on the left of a canonical
+-- equality: a type variable or exactly-saturated type family application.
+data CanEqLHS
+  = TyVarLHS TcTyVar
+  | TyFamLHS TyCon  -- ^ of the family
+             [Xi]   -- ^ exactly saturating the family
+
+instance Outputable CanEqLHS where
+  ppr (TyVarLHS tv)              = ppr tv
+  ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args)
+
 ------------
 data QCInst  -- A much simplified version of ClsInst
              -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical
@@ -247,35 +270,44 @@ data HoleSort = ExprHole Id
                  -- will be an erroring expression for -fdefer-type-errors.
               | TypeHole
                  -- ^ A hole in a type (PartialTypeSignatures)
+              | ConstraintHole
+                 -- ^ A hole in a constraint, like @f :: (_, Eq a) => ...
+                 -- Differentiated from TypeHole because a ConstraintHole
+                 -- is simplified differently. See
+                 -- Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver.
 
 instance Outputable Hole where
   ppr (Hole { hole_sort = ExprHole id
             , hole_occ  = occ
             , hole_ty   = ty })
     = parens $ (braces $ ppr occ <> colon <> ppr id) <+> dcolon <+> ppr ty
-  ppr (Hole { hole_sort = TypeHole
+  ppr (Hole { hole_sort = _other
             , hole_occ  = occ
             , hole_ty   = ty })
     = braces $ ppr occ <> colon <> ppr ty
 
 instance Outputable HoleSort where
-  ppr (ExprHole id) = text "ExprHole:" <> ppr id
-  ppr TypeHole      = text "TypeHole"
+  ppr (ExprHole id)  = text "ExprHole:" <> ppr id
+  ppr TypeHole       = text "TypeHole"
+  ppr ConstraintHole = text "CosntraintHole"
 
 ------------
 -- | Used to indicate extra information about why a CIrredCan is irreducible
 data CtIrredStatus
   = InsolubleCIS   -- this constraint will never be solved
-  | BlockedCIS     -- this constraint is blocked on a coercion hole
-                   -- The hole will appear in the ctEvPred of the constraint with this status
-                   -- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical"
-                   -- Wrinkle (4a)
+  | BlockedCIS HoleSet
+                   -- this constraint is blocked on the coercion hole(s) listed
+                   -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical
+                   -- Wrinkle (4a). Why store the HoleSet? See Wrinkle (2a) of that
+                   -- same Note.
+                   -- INVARIANT: A BlockedCIS is a homogeneous equality whose
+                   --   left hand side can fit in a CanEqLHS.
   | OtherCIS
 
 instance Outputable CtIrredStatus where
-  ppr InsolubleCIS = text "(insoluble)"
-  ppr BlockedCIS   = text "(blocked)"
-  ppr OtherCIS     = text "(soluble)"
+  ppr InsolubleCIS       = text "(insoluble)"
+  ppr (BlockedCIS holes) = parens (text "blocked on" <+> ppr holes)
+  ppr OtherCIS           = text "(soluble)"
 
 {- Note [CIrredCan constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -308,61 +340,11 @@ during constraint solving. See Note [Evidence field of CtEvidence].
 
 Note [Ct kind invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~
-CTyEqCan and CFunEqCan both require that the kind of the lhs matches the kind
-of the rhs. This is necessary because both constraints are used for substitutions
+CEqCan requires that the kind of the lhs matches the kind
+of the rhs. This is necessary because these constraints are used for substitutions
 during solving. If the kinds differed, then the substitution would take a well-kinded
 type to an ill-kinded one.
 
-Note [Almost function-free]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A type is *almost function-free* if it has no type functions (something that
-responds True to isTypeFamilyTyCon), except (possibly)
- * under a forall, or
- * in a coercion (either in a CastTy or a CercionTy)
-
-The RHS of a CTyEqCan must be almost function-free, invariant (TyEq:AFF).
-This is for two reasons:
-
-1. There cannot be a top-level function. If there were, the equality should
-   really be a CFunEqCan, not a CTyEqCan.
-
-2. Nested functions aren't too bad, on the other hand. However, consider this
-   scenario:
-
-     type family F a = r | r -> a
-
-     [D] F ty1 ~ fsk1
-     [D] F ty2 ~ fsk2
-     [D] fsk1 ~ [G Int]
-     [D] fsk2 ~ [G Bool]
-
-     type instance G Int = Char
-     type instance G Bool = Char
-
-   If it was the case that fsk1 = fsk2, then we could unifty ty1 and ty2 --
-   good! They don't look equal -- but if we aggressively reduce that G Int and
-   G Bool they would become equal. The "almost function free" makes sure that
-   these redexes are exposed.
-
-   Note that this equality does *not* depend on casts or coercions, and so
-   skipping these forms is OK. In addition, the result of a type family cannot
-   be a polytype, so skipping foralls is OK, too. We skip foralls because we
-   want the output of the flattener to be almost function-free. See Note
-   [Flattening under a forall] in GHC.Tc.Solver.Flatten.
-
-   As I (Richard E) write this, it is unclear if the scenario pictured above
-   can happen -- I would expect the G Int and G Bool to be reduced. But
-   perhaps it can arise somehow, and maintaining almost function-free is cheap.
-
-Historical note: CTyEqCans used to require only condition (1) above: that no
-type family was at the top of an RHS. But work on #16512 suggested that the
-injectivity checks were not complete, and adding the requirement that functions
-do not appear even in a nested fashion was easy (it was already true, but
-unenforced).
-
-The almost-function-free property is checked by isAlmostFunctionFree in GHC.Tc.Utils.TcType.
-The flattener (in GHC.Tc.Solver.Flatten) produces types that are almost function-free.
-
 Note [Holes]
 ~~~~~~~~~~~~
 This Note explains how GHC tracks *holes*.
@@ -377,10 +359,7 @@ user describing the bit that is left out.
 When a hole is encountered, a new entry of type Hole is added to the ambient
 WantedConstraints. The type (hole_ty) of the hole is then simplified during
 solving (with respect to any Givens in surrounding implications). It is
-reported with all the other errors in GHC.Tc.Errors. No type family reduction
-is done on hole types; this is purely because we think it will produce
-better error messages not to reduce type families. This is why the
-GHC.Tc.Solver.Flatten.flattenType function uses FM_SubstOnly.
+reported with all the other errors in GHC.Tc.Errors.
 
 For expression holes, the user has the option of deferring errors until runtime
 with -fdefer-type-errors. In this case, the hole actually has evidence: this
@@ -459,8 +438,7 @@ instance Outputable Ct where
   ppr ct = ppr (ctEvidence ct) <+> parens pp_sort
     where
       pp_sort = case ct of
-         CTyEqCan {}      -> text "CTyEqCan"
-         CFunEqCan {}     -> text "CFunEqCan"
+         CEqCan {}        -> text "CEqCan"
          CNonCanonical {} -> text "CNonCanonical"
          CDictCan { cc_pend_sc = pend_sc }
             | pend_sc   -> text "CDictCan(psc)"
@@ -470,6 +448,40 @@ instance Outputable Ct where
             | pend_sc   -> text "CQuantCan(psc)"
             | otherwise -> text "CQuantCan"
 
+-----------------------------------
+-- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated
+-- type family application?
+-- Does not look through type synonyms.
+canEqLHS_maybe :: Xi -> Maybe CanEqLHS
+canEqLHS_maybe xi
+  | Just tv <- tcGetTyVar_maybe xi
+  = Just $ TyVarLHS tv
+
+  | Just (tc, args) <- tcSplitTyConApp_maybe xi
+  , isTypeFamilyTyCon tc
+  , args `lengthIs` tyConArity tc
+  = Just $ TyFamLHS tc args
+
+  | otherwise
+  = Nothing
+
+-- | Convert a 'CanEqLHS' back into a 'Type'
+canEqLHSType :: CanEqLHS -> TcType
+canEqLHSType (TyVarLHS tv) = mkTyVarTy tv
+canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args
+
+-- | Retrieve the kind of a 'CanEqLHS'
+canEqLHSKind :: CanEqLHS -> TcKind
+canEqLHSKind (TyVarLHS tv) = tyVarKind tv
+canEqLHSKind (TyFamLHS fam_tc fam_args) = piResultTys (tyConKind fam_tc) fam_args
+
+-- | Are two 'CanEqLHS's equal?
+eqCanEqLHS :: CanEqLHS -> CanEqLHS -> Bool
+eqCanEqLHS (TyVarLHS tv1) (TyVarLHS tv2) = tv1 == tv2
+eqCanEqLHS (TyFamLHS fam_tc1 fam_args1) (TyFamLHS fam_tc2 fam_args2)
+  = tcEqTyConApps fam_tc1 fam_args1 fam_tc2 fam_args2
+eqCanEqLHS _ _ = False
+
 {-
 ************************************************************************
 *                                                                      *
@@ -705,26 +717,6 @@ isGivenCt = isGiven . ctEvidence
 isDerivedCt :: Ct -> Bool
 isDerivedCt = isDerived . ctEvidence
 
-isCTyEqCan :: Ct -> Bool
-isCTyEqCan (CTyEqCan {})  = True
-isCTyEqCan _              = False
-
-isCDictCan_Maybe :: Ct -> Maybe Class
-isCDictCan_Maybe (CDictCan {cc_class = cls })  = Just cls
-isCDictCan_Maybe _              = Nothing
-
-isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type])
-isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis)
-isCFunEqCan_maybe _ = Nothing
-
-isCFunEqCan :: Ct -> Bool
-isCFunEqCan (CFunEqCan {}) = True
-isCFunEqCan _ = False
-
-isCNonCanonical :: Ct -> Bool
-isCNonCanonical (CNonCanonical {}) = True
-isCNonCanonical _ = False
-
 {- Note [Custom type errors in constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -1116,8 +1108,7 @@ data Implication
                                  --   (order does not matter)
                                  -- See Invariant (GivenInv) in GHC.Tc.Utils.TcType
 
-      ic_no_eqs :: Bool,         -- True  <=> ic_givens have no equalities, for sure
-                                 -- False <=> ic_givens might have equalities
+      ic_given_eqs :: HasGivenEqs,  -- Are there Given equalities here?
 
       ic_warn_inaccessible :: Bool,
                                  -- True  <=> -Winaccessible-code is enabled
@@ -1164,7 +1155,7 @@ implicationPrototype
             , ic_skols      = []
             , ic_given      = []
             , ic_wanted     = emptyWC
-            , ic_no_eqs     = False
+            , ic_given_eqs  = MaybeGivenEqs
             , ic_status     = IC_Unsolved
             , ic_need_inner = emptyVarSet
             , ic_need_outer = emptyVarSet }
@@ -1181,9 +1172,47 @@ data ImplicStatus
 
   | IC_Unsolved   -- Neither of the above; might go either way
 
+-- | Does this implication have Given equalities?
+-- See Note [When does an implication have given equalities?] in GHC.Tc.Solver.Monad,
+-- which also explains why we need three options here. Also, see
+-- Note [Suppress redundant givens during error reporting] in GHC.Tc.Errors
+--
+--                  Stops floating  |   Suppresses Givens in errors
+--                  -----------------------------------------------
+--  NoGivenEqs         NO           |         YES
+--  LocalGivenEqs      NO           |         NO
+--  MaybeGivenEqs      YES          |         NO
+--
+-- Examples:
+--
+--  NoGivenEqs:      Eq a => ...
+--                   (Show a, Num a) => ...
+--                   forall a. a ~ Either Int Bool => ...
+--                      See Note [Let-bound skolems] in GHC.Tc.Solver.Monad for
+--                      that last one
+--
+--  LocalGivenEqs:   forall a b. F a ~ G b => ...
+--                   forall a. F a ~ Int => ...
+--
+--  MaybeGivenEqs:   (a ~ b) => ...
+--                   forall a. F a ~ b => ...
+--
+-- The check is conservative. A MaybeGivenEqs might not have any equalities.
+-- A LocalGivenEqs might local equalities, but it definitely does not have non-local
+-- equalities. A NoGivenEqs definitely does not have equalities (except let-bound
+-- skolems).
+data HasGivenEqs
+  = NoGivenEqs      -- definitely no given equalities,
+                    -- except by Note [Let-bound skolems] in GHC.Tc.Solver.Monad
+  | LocalGivenEqs   -- might have Given equalities that affect only local skolems
+                    -- e.g. forall a b. (a ~ F b) => ...; definitely no others
+  | MaybeGivenEqs   -- might have any kind of Given equalities; no floating out
+                    -- is possible.
+  deriving Eq
+
 instance Outputable Implication where
   ppr (Implic { ic_tclvl = tclvl, ic_skols = skols
-              , ic_given = given, ic_no_eqs = no_eqs
+              , ic_given = given, ic_given_eqs = given_eqs
               , ic_wanted = wanted, ic_status = status
               , ic_binds = binds
               , ic_need_inner = need_in, ic_need_outer = need_out
@@ -1191,7 +1220,7 @@ instance Outputable Implication where
    = hang (text "Implic" <+> lbrace)
         2 (sep [ text "TcLevel =" <+> ppr tclvl
                , text "Skolems =" <+> pprTyVars skols
-               , text "No-eqs =" <+> ppr no_eqs
+               , text "Given-eqs =" <+> ppr given_eqs
                , text "Status =" <+> ppr status
                , hang (text "Given =")  2 (pprEvVars given)
                , hang (text "Wanted =") 2 (ppr wanted)
@@ -1212,6 +1241,25 @@ checkTelescopeSkol :: SkolemInfo -> Bool
 checkTelescopeSkol (ForAllSkol {}) = True
 checkTelescopeSkol _               = False
 
+instance Outputable HasGivenEqs where
+  ppr NoGivenEqs    = text "NoGivenEqs"
+  ppr LocalGivenEqs = text "LocalGivenEqs"
+  ppr MaybeGivenEqs = text "MaybeGivenEqs"
+
+-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs
+instance Semigroup HasGivenEqs where
+  NoGivenEqs <> other = other
+  other <> NoGivenEqs = other
+
+  MaybeGivenEqs <> _other = MaybeGivenEqs
+  _other <> MaybeGivenEqs = MaybeGivenEqs
+
+  LocalGivenEqs <> LocalGivenEqs = LocalGivenEqs
+
+-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs
+instance Monoid HasGivenEqs where
+  mempty = NoGivenEqs
+
 {- Note [Checking telescopes]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When kind-checking a /user-written/ type, we might have a "bad telescope"
@@ -1420,7 +1468,7 @@ data TcEvDest
 
   | HoleDest  CoercionHole  -- ^ fill in this hole with the evidence
               -- HoleDest is always used for type-equalities
-              -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep"
+              -- See Note [Coercion holes] in GHC.Core.TyCo.Rep
 
 data CtEvidence
   = CtGiven    -- Truly given, not depending on subgoals
@@ -1536,9 +1584,7 @@ Constraints come in four flavours:
 
 * [WD] Wanted WDeriv: a single constraint that represents
                       both [W] and [D]
-  We keep them paired as one both for efficiency, and because
-  when we have a finite map  F tys -> CFunEqCan, it's inconvenient
-  to have two CFunEqCans in the range
+  We keep them paired as one both for efficiency
 
 The ctev_nosh field of a Wanted distinguishes between [W] and [WD]
 
@@ -1561,11 +1607,6 @@ data ShadowInfo
              -- See Note [The improvement story and derived shadows] in GHC.Tc.Solver.Monad
   deriving( Eq )
 
-isGivenOrWDeriv :: CtFlavour -> Bool
-isGivenOrWDeriv Given           = True
-isGivenOrWDeriv (Wanted WDeriv) = True
-isGivenOrWDeriv _               = False
-
 instance Outputable CtFlavour where
   ppr Given           = text "[G]"
   ppr (Wanted WDeriv) = text "[WD]"
@@ -1591,17 +1632,15 @@ ctFlavourRole :: Ct -> CtFlavourRole
 -- Uses short-cuts to role for special cases
 ctFlavourRole (CDictCan { cc_ev = ev })
   = (ctEvFlavour ev, NomEq)
-ctFlavourRole (CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel })
+ctFlavourRole (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })
   = (ctEvFlavour ev, eq_rel)
-ctFlavourRole (CFunEqCan { cc_ev = ev })
-  = (ctEvFlavour ev, NomEq)
 ctFlavourRole ct
   = ctEvFlavourRole (ctEvidence ct)
 
 {- Note [eqCanRewrite]
 ~~~~~~~~~~~~~~~~~~~~~~
-(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form
-tv ~ ty) can be used to rewrite ct2.  It must satisfy the properties of
+(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CEqCan of form
+lhs ~ ty) can be used to rewrite ct2.  It must satisfy the properties of
 a can-rewrite relation, see Definition [Can-rewrite relation] in
 GHC.Tc.Solver.Monad.
 
@@ -1667,47 +1706,11 @@ eqMayRewriteFR (Wanted WDeriv, NomEq) (Wanted WDeriv, NomEq) = True
 eqMayRewriteFR (Derived,       NomEq) (Wanted WDeriv, NomEq) = True
 eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2
 
------------------
-{- Note [funEqCanDischarge]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have two CFunEqCans with the same LHS:
-    (x1:F ts ~ f1) `funEqCanDischarge` (x2:F ts ~ f2)
-Can we drop x2 in favour of x1, either unifying
-f2 (if it's a flatten meta-var) or adding a new Given
-(f1 ~ f2), if x2 is a Given?
-
-Answer: yes if funEqCanDischarge is true.
--}
-
-funEqCanDischarge
-  :: CtEvidence -> CtEvidence
-  -> ( SwapFlag   -- NotSwapped => lhs can discharge rhs
-                  -- Swapped    => rhs can discharge lhs
-     , Bool)      -- True <=> upgrade non-discharded one
-                  --          from [W] to [WD]
--- See Note [funEqCanDischarge]
-funEqCanDischarge ev1 ev2
-  = ASSERT2( ctEvEqRel ev1 == NomEq, ppr ev1 )
-    ASSERT2( ctEvEqRel ev2 == NomEq, ppr ev2 )
-    -- CFunEqCans are all Nominal, hence asserts
-    funEqCanDischargeF (ctEvFlavour ev1) (ctEvFlavour ev2)
-
-funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool)
-funEqCanDischargeF Given           _               = (NotSwapped, False)
-funEqCanDischargeF _               Given           = (IsSwapped,  False)
-funEqCanDischargeF (Wanted WDeriv) _               = (NotSwapped, False)
-funEqCanDischargeF _               (Wanted WDeriv) = (IsSwapped,  True)
-funEqCanDischargeF (Wanted WOnly)  (Wanted WOnly)  = (NotSwapped, False)
-funEqCanDischargeF (Wanted WOnly)  Derived         = (NotSwapped, True)
-funEqCanDischargeF Derived         (Wanted WOnly)  = (IsSwapped,  True)
-funEqCanDischargeF Derived         Derived         = (NotSwapped, False)
-
-
 {- Note [eqCanDischarge]
 ~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have two identical CTyEqCan equality constraints
+Suppose we have two identical CEqCan equality constraints
 (i.e. both LHS and RHS are the same)
-      (x1:a~t) `eqCanDischarge` (xs:a~t)
+      (x1:lhs~t) `eqCanDischarge` (xs:lhs~t)
 Can we just drop x2 in favour of x1?
 
 Answer: yes if eqCanDischarge is true.
diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs
index 127723d4f7748301073126524c71f46be711da70..602d06608c9f46919d9c3ab2e7c80c9a9fc8d657 100644
--- a/compiler/GHC/Tc/Types/Evidence.hs
+++ b/compiler/GHC/Tc/Types/Evidence.hs
@@ -35,14 +35,15 @@ module GHC.Tc.Types.Evidence (
 
   -- * TcCoercion
   TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole,
-  TcMCoercion,
+  TcMCoercion, TcMCoercionN, TcMCoercionR,
   Role(..), LeftOrRight(..), pickLR,
   mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo,
   mkTcTyConAppCo, mkTcAppCo, mkTcFunCo,
   mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos,
-  mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo,
-  tcDowngradeRole,
-  mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflLeftCo, mkTcPhantomCo,
+  mkTcSymCo, mkTcSymMCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSymCo,
+  maybeTcSubCo, tcDowngradeRole,
+  mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflRightMCo, mkTcGReflLeftCo, mkTcGReflLeftMCo,
+  mkTcPhantomCo,
   mkTcCoherenceLeftCo,
   mkTcCoherenceRightCo,
   mkTcKindCo,
@@ -76,6 +77,7 @@ import GHC.Types.Var.Set
 import GHC.Core.Predicate
 import GHC.Types.Name
 import GHC.Data.Pair
+import GHC.Types.Basic
 
 import GHC.Core
 import GHC.Core.Class (Class, classSCSelId )
@@ -111,10 +113,13 @@ type TcCoercion  = Coercion
 type TcCoercionN = CoercionN    -- A Nominal          coercion ~N
 type TcCoercionR = CoercionR    -- A Representational coercion ~R
 type TcCoercionP = CoercionP    -- a phantom coercion
-type TcMCoercion = MCoercion
+type TcMCoercion  = MCoercion
+type TcMCoercionN = MCoercionN  -- nominal
+type TcMCoercionR = MCoercionR  -- representational
 
 mkTcReflCo             :: Role -> TcType -> TcCoercion
 mkTcSymCo              :: TcCoercion -> TcCoercion
+mkTcSymMCo             :: TcMCoercion -> TcMCoercion
 mkTcTransCo            :: TcCoercion -> TcCoercion -> TcCoercion
 mkTcNomReflCo          :: TcType -> TcCoercionN
 mkTcRepReflCo          :: TcType -> TcCoercionR
@@ -129,11 +134,13 @@ mkTcForAllCo           :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion
 mkTcForAllCos          :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion
 mkTcNthCo              :: Role -> Int -> TcCoercion -> TcCoercion
 mkTcLRCo               :: LeftOrRight -> TcCoercion -> TcCoercion
-mkTcSubCo              :: TcCoercionN -> TcCoercionR
+mkTcSubCo              :: HasDebugCallStack => TcCoercionN -> TcCoercionR
 tcDowngradeRole        :: Role -> Role -> TcCoercion -> TcCoercion
 mkTcAxiomRuleCo        :: CoAxiomRule -> [TcCoercion] -> TcCoercionR
 mkTcGReflRightCo       :: Role -> TcType -> TcCoercionN -> TcCoercion
+mkTcGReflRightMCo      :: Role -> TcType -> TcMCoercionN -> TcCoercion
 mkTcGReflLeftCo        :: Role -> TcType -> TcCoercionN -> TcCoercion
+mkTcGReflLeftMCo       :: Role -> TcType -> TcMCoercionN -> TcCoercion
 mkTcCoherenceLeftCo    :: Role -> TcType -> TcCoercionN
                        -> TcCoercion -> TcCoercion
 mkTcCoherenceRightCo   :: Role -> TcType -> TcCoercionN
@@ -153,6 +160,7 @@ isTcReflexiveCo        :: TcCoercion -> Bool
 
 mkTcReflCo             = mkReflCo
 mkTcSymCo              = mkSymCo
+mkTcSymMCo             = mkSymMCo
 mkTcTransCo            = mkTransCo
 mkTcNomReflCo          = mkNomReflCo
 mkTcRepReflCo          = mkRepReflCo
@@ -169,7 +177,9 @@ mkTcSubCo              = mkSubCo
 tcDowngradeRole        = downgradeRole
 mkTcAxiomRuleCo        = mkAxiomRuleCo
 mkTcGReflRightCo       = mkGReflRightCo
+mkTcGReflRightMCo      = mkGReflRightMCo
 mkTcGReflLeftCo        = mkGReflLeftCo
+mkTcGReflLeftMCo       = mkGReflLeftMCo
 mkTcCoherenceLeftCo    = mkCoherenceLeftCo
 mkTcCoherenceRightCo   = mkCoherenceRightCo
 mkTcPhantomCo          = mkPhantomCo
@@ -184,10 +194,14 @@ isTcReflexiveCo        = isReflexiveCo
 
 -- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing.
 -- Note that the input coercion should always be nominal.
-maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion
+maybeTcSubCo :: HasDebugCallStack => EqRel -> TcCoercionN -> TcCoercion
 maybeTcSubCo NomEq  = id
 maybeTcSubCo ReprEq = mkTcSubCo
 
+-- | If a 'SwapFlag' is 'IsSwapped', flip the orientation of a coercion
+maybeTcSymCo :: SwapFlag -> TcCoercion -> TcCoercion
+maybeTcSymCo IsSwapped  co = mkTcSymCo co
+maybeTcSymCo NotSwapped co = co
 
 {-
 %************************************************************************
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 6b66c32ccc34d50f6c1725c8897e28e90a3f13a3..eacdf40bcefbda35bfc7c67c32207d4ccfa1e80c 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -111,7 +111,7 @@ module GHC.Tc.Utils.Monad(
   getTcLevel, setTcLevel, isTouchableTcM,
   getLclTypeEnv, setLclTypeEnv,
   traceTcConstraints,
-  emitNamedTypeHole, emitAnonTypeHole,
+  emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole,
 
   -- * Template Haskell context
   recordThUse, recordThSpliceUse,
@@ -1779,16 +1779,26 @@ traceTcConstraints msg
          hang (text (msg ++ ": LIE:")) 2 (ppr lie)
        }
 
-emitAnonTypeHole :: TcTyVar -> TcM ()
-emitAnonTypeHole tv
+data IsExtraConstraint = YesExtraConstraint
+                       | NoExtraConstraint
+
+instance Outputable IsExtraConstraint where
+  ppr YesExtraConstraint = text "YesExtraConstraint"
+  ppr NoExtraConstraint  = text "NoExtraConstraint"
+
+emitAnonTypeHole :: IsExtraConstraint
+                 -> TcTyVar -> TcM ()
+emitAnonTypeHole extra_constraints tv
   = do { ct_loc <- getCtLocM (TypeHoleOrigin occ) Nothing
-       ; let hole = Hole { hole_sort = TypeHole
+       ; let hole = Hole { hole_sort = sort
                          , hole_occ  = occ
                          , hole_ty   = mkTyVarTy tv
                          , hole_loc  = ct_loc }
        ; emitHole hole }
   where
     occ = mkTyVarOcc "_"
+    sort | YesExtraConstraint <- extra_constraints = ConstraintHole
+         | otherwise                               = TypeHole
 
 emitNamedTypeHole :: (Name, TcTyVar) -> TcM ()
 emitNamedTypeHole (name, tv)
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index 452c795c3be68c5091ba2b52a189ab3156a2a004..62fab5500b58d8d5ef898648efa5af7dda33cafa 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -25,7 +25,7 @@ module GHC.Tc.Utils.TcMType (
   newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind,
   newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel,
   newAnonMetaTyVar, cloneMetaTyVar,
-  newFmvTyVar, newFskTyVar,
+  newCycleBreakerTyVar,
 
   newMultiplicityVar,
   readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
@@ -183,7 +183,7 @@ newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence
 -- Deals with both equality and non-equality predicates
 newWanted orig t_or_k pty
   = do loc <- getCtLocM orig t_or_k
-       d <- if isEqPrimPred pty then HoleDest  <$> newCoercionHole YesBlockSubst pty
+       d <- if isEqPrimPred pty then HoleDest  <$> newCoercionHole pty
                                 else EvVarDest <$> newEvVar pty
        return $ CtWanted { ctev_dest = d
                          , ctev_pred = pty
@@ -199,8 +199,8 @@ newWanteds orig = mapM (newWanted orig Nothing)
 
 cloneWanted :: Ct -> TcM Ct
 cloneWanted ct
-  | ev@(CtWanted { ctev_dest = HoleDest old_hole, ctev_pred = pty }) <- ctEvidence ct
-  = do { co_hole <- newCoercionHole (ch_blocker old_hole) pty
+  | ev@(CtWanted { ctev_pred = pty }) <- ctEvidence ct
+  = do { co_hole <- newCoercionHole pty
        ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) }
   | otherwise
   = return ct
@@ -250,7 +250,7 @@ emitDerivedEqs origin pairs
 -- | Emits a new equality constraint
 emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion
 emitWantedEq origin t_or_k role ty1 ty2
-  = do { hole <- newCoercionHole YesBlockSubst pty
+  = do { hole <- newCoercionHole pty
        ; loc <- getCtLocM origin (Just t_or_k)
        ; emitSimple $ mkNonCanonical $
          CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
@@ -323,16 +323,12 @@ newImplication
 ************************************************************************
 -}
 
-newCoercionHole :: BlockSubstFlag  -- should the presence of this hole block substitution?
-                                   -- See sub-wrinkle in TcCanonical
-                                   -- Note [Equalities with incompatible kinds]
-                -> TcPredType -> TcM CoercionHole
-newCoercionHole blocker pred_ty
+newCoercionHole :: TcPredType -> TcM CoercionHole
+newCoercionHole pred_ty
   = do { co_var <- newEvVar pred_ty
-       ; traceTc "New coercion hole:" (ppr co_var <+> ppr blocker)
+       ; traceTc "New coercion hole:" (ppr co_var)
        ; ref <- newMutVar Nothing
-       ; return $ CoercionHole { ch_co_var = co_var, ch_blocker = blocker
-                               , ch_ref = ref } }
+       ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } }
 
 -- | Put a value in a coercion hole
 fillCoercionHole :: CoercionHole -> Coercion -> TcM ()
@@ -805,11 +801,10 @@ influences the way it is tidied; see TypeRep.tidyTyVarBndr.
 metaInfoToTyVarName :: MetaInfo -> FastString
 metaInfoToTyVarName  meta_info =
   case meta_info of
-       TauTv        -> fsLit "t"
-       FlatMetaTv   -> fsLit "fmv"
-       FlatSkolTv   -> fsLit "fsk"
-       TyVarTv      -> fsLit "a"
-       RuntimeUnkTv -> fsLit "r"
+       TauTv          -> fsLit "t"
+       TyVarTv        -> fsLit "a"
+       RuntimeUnkTv   -> fsLit "r"
+       CycleBreakerTv -> fsLit "b"
 
 newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
 newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi
@@ -875,19 +870,13 @@ cloneAnonMetaTyVar info tv kind
         ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar))
         ; return tyvar }
 
-newFskTyVar :: TcType -> TcM TcTyVar
-newFskTyVar fam_ty
-  = do { details <- newMetaDetails FlatSkolTv
-       ; name <- newMetaTyVarName (fsLit "fsk")
-       ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }
-
-newFmvTyVar :: TcType -> TcM TcTyVar
--- Very like newMetaTyVar, except sets mtv_tclvl to one less
--- so that the fmv is untouchable.
-newFmvTyVar fam_ty
-  = do { details <- newMetaDetails FlatMetaTv
-       ; name <- newMetaTyVarName (fsLit "s")
-       ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }
+-- Make a new CycleBreakerTv. See Note [Type variable cycles in Givens]
+-- in GHC.Tc.Solver.Canonical.
+newCycleBreakerTyVar :: TcKind -> TcM TcTyVar
+newCycleBreakerTyVar kind
+  = do { details <- newMetaDetails CycleBreakerTv
+       ; name <- newMetaTyVarName (fsLit "cbv")
+       ; return (mkTcTyVar name kind details) }
 
 newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
 newMetaDetails info
@@ -2179,18 +2168,16 @@ Why?, for example:
 
 - For CIrredCan we want to see if a constraint is insoluble with insolubleWC
 
-On the other hand, we change CTyEqCan to CNonCanonical, because of all of
-CTyEqCan's invariants, which can break during zonking. Besides, the constraint
+On the other hand, we change CEqCan to CNonCanonical, because of all of
+CEqCan's invariants, which can break during zonking. (Example: a ~R alpha, where
+we have alpha := N Int, where N is a newtype.) Besides, the constraint
 will be canonicalised again, so there is little benefit in keeping the
-CTyEqCan structure.
-
-NB: we do not expect to see any CFunEqCans, because zonkCt is only
-called on unflattened constraints.
+CEqCan structure.
 
 NB: Constraints are always re-flattened etc by the canonicaliser in
 @GHC.Tc.Solver.Canonical@ even if they come in as CDictCan. Only canonical constraints that
 are actually in the inert set carry all the guarantees. So it is okay if zonkCt
-creates e.g. a CDictCan where the cc_tyars are /not/ function free.
+creates e.g. a CDictCan where the cc_tyars are /not/ fully reduced.
 -}
 
 zonkCt :: Ct -> TcM Ct
@@ -2200,7 +2187,7 @@ zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args })
        ; args' <- mapM zonkTcType args
        ; return $ ct { cc_ev = ev', cc_tyargs = args' } }
 
-zonkCt (CTyEqCan { cc_ev = ev })
+zonkCt (CEqCan { cc_ev = ev })
   = mkNonCanonical <$> zonkCtEvidence ev
 
 zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_status flag
@@ -2208,10 +2195,7 @@ zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_status flag
        ; return (ct { cc_ev = ev' }) }
 
 zonkCt ct
-  = ASSERT( not (isCFunEqCan ct) )
-  -- We do not expect to see any CFunEqCans, because zonkCt is only called on
-  -- unflattened constraints.
-    do { fl' <- zonkCtEvidence (ctEvidence ct)
+  = do { fl' <- zonkCtEvidence (ctEvidence ct)
        ; return (mkNonCanonical fl') }
 
 zonkCtEvidence :: CtEvidence -> TcM CtEvidence
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index c408ffb54cad92cf8b4512c04469d941ca43a710..9d115050530a7848628f98402c5b9ae5d12a8639 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -42,8 +42,7 @@ module GHC.Tc.Utils.TcType (
   MetaDetails(Flexi, Indirect), MetaInfo(..),
   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,
   tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,  isTyConableTyVar,
-  isFskTyVar, isFmvTyVar, isFlattenTyVar,
-  isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo,
+  isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo,
   isFlexi, isIndirect, isRuntimeUnkSkol,
   metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,
   isTouchableMetaTyVar,
@@ -78,14 +77,15 @@ module GHC.Tc.Utils.TcType (
   -- Again, newtypes are opaque
   eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX,
   pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,
+  tcEqTyConApps,
   isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,
   isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
   isIntegerTy, isNaturalTy,
   isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred,
   isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
-  isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck,
+  isPredTy, isTyVarClassPred, isInsolubleOccursCheck,
   checkValidClsArgs, hasTyVarHead,
-  isRigidTy, isAlmostFunctionFree,
+  isRigidTy,
 
   ---------------------------------
   -- Misc type manipulators
@@ -107,7 +107,7 @@ module GHC.Tc.Utils.TcType (
 
   -- * Finding "exact" (non-dead) type variables
   exactTyCoVarsOfType, exactTyCoVarsOfTypes,
-  anyRewritableTyVar,
+  anyRewritableTyVar, anyRewritableTyFamApp, anyRewritableCanEqLHS,
 
   ---------------------------------
   -- Foreign import and export
@@ -554,29 +554,22 @@ data MetaInfo
                    --   unified with a type, only with a type variable
                    -- See Note [Signature skolems]
 
-   | FlatMetaTv    -- A flatten meta-tyvar
-                   -- It is a meta-tyvar, but it is always untouchable, with level 0
-                   -- See Note [The flattening story] in GHC.Tc.Solver.Flatten
-
-   | FlatSkolTv    -- A flatten skolem tyvar
-                   -- Just like FlatMetaTv, but is completely "owned" by
-                   --   its Given CFunEqCan.
-                   -- It is filled in /only/ by unflattenGivens
-                   -- See Note [The flattening story] in GHC.Tc.Solver.Flatten
-
    | RuntimeUnkTv  -- A unification variable used in the GHCi debugger.
                    -- It /is/ allowed to unify with a polytype, unlike TauTv
 
+   | CycleBreakerTv  -- Used to fix occurs-check problems in Givens
+                     -- See Note [Type variable cycles in Givens] in
+                     -- GHC.Tc.Solver.Canonical
+
 instance Outputable MetaDetails where
   ppr Flexi         = text "Flexi"
   ppr (Indirect ty) = text "Indirect" <+> ppr ty
 
 instance Outputable MetaInfo where
-  ppr TauTv         = text "tau"
-  ppr TyVarTv       = text "tyv"
-  ppr FlatMetaTv    = text "fmv"
-  ppr FlatSkolTv    = text "fsk"
-  ppr RuntimeUnkTv  = text "rutv"
+  ppr TauTv          = text "tau"
+  ppr TyVarTv        = text "tyv"
+  ppr RuntimeUnkTv   = text "rutv"
+  ppr CycleBreakerTv = text "cbv"
 
 {- *********************************************************************
 *                                                                      *
@@ -615,7 +608,7 @@ Note [TcLevel and untouchable type variables]
 
 * A unification variable is *touchable* if its level number
   is EQUAL TO that of its immediate parent implication,
-  and it is a TauTv or TyVarTv (but /not/ FlatMetaTv or FlatSkolTv)
+  and it is a TauTv or TyVarTv (but /not/ CycleBreakerTv)
 
 Note [WantedInv]
 ~~~~~~~~~~~~~~~~
@@ -854,27 +847,41 @@ isTyFamFree :: Type -> Bool
 -- ^ Check that a type does not contain any type family applications.
 isTyFamFree = null . tcTyFamInsts
 
-anyRewritableTyVar :: Bool    -- Ignore casts and coercions
-                   -> EqRel   -- Ambient role
-                   -> (EqRel -> TcTyVar -> Bool)
-                   -> TcType -> Bool
--- (anyRewritableTyVar ignore_cos pred ty) returns True
---    if the 'pred' returns True of any free TyVar in 'ty'
+any_rewritable :: Bool    -- Ignore casts and coercions
+               -> EqRel   -- Ambient role
+               -> (EqRel -> TcTyVar -> Bool)           -- check tyvar
+               -> (EqRel -> TyCon -> [TcType] -> Bool) -- check type family
+               -> (TyCon -> Bool)                      -- expand type synonym?
+               -> TcType -> Bool
+-- Checks every tyvar and tyconapp (not including FunTys) within a type,
+-- ORing the results of the predicates above together
 -- Do not look inside casts and coercions if 'ignore_cos' is True
 -- See Note [anyRewritableTyVar must be role-aware]
-anyRewritableTyVar ignore_cos role pred ty
-  = go role emptyVarSet ty
+--
+-- This looks like it should use foldTyCo, but that function is
+-- role-agnostic, and this one must be role-aware. We could make
+-- foldTyCon role-aware, but that may slow down more common usages.
+{-# INLINE any_rewritable #-} -- this allows specialization of predicates
+any_rewritable ignore_cos role tv_pred tc_pred should_expand
+  = go role emptyVarSet
   where
-    -- NB: No need to expand synonyms, because we can find
-    -- all free variables of a synonym by looking at its
-    -- arguments
-
     go_tv rl bvs tv | tv `elemVarSet` bvs = False
-                    | otherwise           = pred rl tv
+                    | otherwise           = tv_pred rl tv
+
+    go rl bvs ty@(TyConApp tc tys)
+      | isTypeSynonymTyCon tc
+      , should_expand tc
+      , Just ty' <- tcView ty   -- should always match
+      = go rl bvs ty'
+
+      | tc_pred rl tc tys
+      = True
+
+      | otherwise
+      = go_tc rl bvs tc tys
 
     go rl bvs (TyVarTy tv)       = go_tv rl bvs tv
     go _ _     (LitTy {})        = False
-    go rl bvs (TyConApp tc tys)  = go_tc rl bvs tc tys
     go rl bvs (AppTy fun arg)    = go rl bvs fun || go NomEq bvs arg
     go rl bvs (FunTy _ w arg res)  = go NomEq bvs arg_rep || go NomEq bvs res_rep ||
                                      go rl bvs arg || go rl bvs res || go NomEq bvs w
@@ -898,6 +905,36 @@ anyRewritableTyVar ignore_cos role pred ty
       -- We don't have an equivalent of anyRewritableTyVar for coercions
       -- (at least not yet) so take the free vars and test them
 
+anyRewritableTyVar :: Bool     -- Ignore casts and coercions
+                   -> EqRel    -- Ambient role
+                   -> (EqRel -> TcTyVar -> Bool)  -- check tyvar
+                   -> TcType -> Bool
+anyRewritableTyVar ignore_cos role pred
+  = any_rewritable ignore_cos role pred
+      (\ _ _ _ -> False) -- don't check tyconapps
+      (\ _ -> False)     -- don't expand synonyms
+    -- NB: No need to expand synonyms, because we can find
+    -- all free variables of a synonym by looking at its
+    -- arguments
+
+anyRewritableTyFamApp :: EqRel   -- Ambient role
+                      -> (EqRel -> TyCon -> [TcType] -> Bool) -- check tyconapp
+                          -- should return True only for type family applications
+                      -> TcType -> Bool
+  -- always ignores casts & coercions
+anyRewritableTyFamApp role check_tyconapp
+  = any_rewritable True role (\ _ _ -> False) check_tyconapp (not . isFamFreeTyCon)
+
+-- This version is used by shouldSplitWD. It *does* look in casts
+-- and coercions, and it always expands type synonyms whose RHSs mention
+-- type families.
+anyRewritableCanEqLHS :: EqRel   -- Ambient role
+                      -> (EqRel -> TcTyVar -> Bool)            -- check tyvar
+                      -> (EqRel -> TyCon -> [TcType] -> Bool)  -- check type family
+                      -> TcType -> Bool
+anyRewritableCanEqLHS role check_tyvar check_tyconapp
+  = any_rewritable False role check_tyvar check_tyconapp (not . isFamFreeTyCon)
+
 {- Note [anyRewritableTyVar must be role-aware]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 anyRewritableTyVar is used during kick-out from the inert set,
@@ -969,7 +1006,7 @@ isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
 isTouchableMetaTyVar ctxt_tclvl tv
   | isTyVar tv -- See Note [Coercion variables in free variable lists]
   , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv
-  , not (isFlattenInfo info)
+  , isTouchableInfo info
   = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,
              ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )
     tv_tclvl `sameDepthAs` ctxt_tclvl
@@ -980,7 +1017,7 @@ isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool
 isFloatedTouchableMetaTyVar ctxt_tclvl tv
   | isTyVar tv -- See Note [Coercion variables in free variable lists]
   , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv
-  , not (isFlattenInfo info)
+  , isTouchableInfo info
   = tv_tclvl `strictlyDeeperThan` ctxt_tclvl
 
   | otherwise = False
@@ -989,8 +1026,7 @@ isImmutableTyVar :: TyVar -> Bool
 isImmutableTyVar tv = isSkolemTyVar tv
 
 isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
-  isMetaTyVar, isAmbiguousTyVar,
-  isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool
+  isMetaTyVar, isAmbiguousTyVar, isCycleBreakerTyVar :: TcTyVar -> Bool
 
 isTyConableTyVar tv
         -- True of a meta-type variable that can be filled in
@@ -1002,25 +1038,6 @@ isTyConableTyVar tv
         _                             -> True
   | otherwise = True
 
-isFmvTyVar tv
-  = ASSERT2( tcIsTcTyVar tv, ppr tv )
-    case tcTyVarDetails tv of
-        MetaTv { mtv_info = FlatMetaTv } -> True
-        _                                -> False
-
-isFskTyVar tv
-  = ASSERT2( tcIsTcTyVar tv, ppr tv )
-    case tcTyVarDetails tv of
-        MetaTv { mtv_info = FlatSkolTv } -> True
-        _                                -> False
-
--- | True of both given and wanted flatten-skolems (fmv and fsk)
-isFlattenTyVar tv
-  = ASSERT2( tcIsTcTyVar tv, ppr tv )
-    case tcTyVarDetails tv of
-        MetaTv { mtv_info = info } -> isFlattenInfo info
-        _                          -> False
-
 isSkolemTyVar tv
   = ASSERT2( tcIsTcTyVar tv, ppr tv )
     case tcTyVarDetails tv of
@@ -1054,6 +1071,14 @@ isAmbiguousTyVar tv
         _             -> False
   | otherwise = False
 
+isCycleBreakerTyVar tv
+  | isTyVar tv -- See Note [Coercion variables in free variable lists]
+  , MetaTv { mtv_info = CycleBreakerTv } <- tcTyVarDetails tv
+  = True
+
+  | otherwise
+  = False
+
 isMetaTyVarTy :: TcType -> Bool
 isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv
 isMetaTyVarTy _            = False
@@ -1064,10 +1089,10 @@ metaTyVarInfo tv
       MetaTv { mtv_info = info } -> info
       _ -> pprPanic "metaTyVarInfo" (ppr tv)
 
-isFlattenInfo :: MetaInfo -> Bool
-isFlattenInfo FlatMetaTv = True
-isFlattenInfo FlatSkolTv = True
-isFlattenInfo _          = False
+isTouchableInfo :: MetaInfo -> Bool
+isTouchableInfo info
+  | CycleBreakerTv <- info = False
+  | otherwise              = True
 
 metaTyVarTcLevel :: TcTyVar -> TcLevel
 metaTyVarTcLevel tv
@@ -1540,7 +1565,15 @@ pickyEqType :: TcType -> TcType -> Bool
 -- This ignores kinds and coercions, because this is used only for printing.
 pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2
 
-
+-- | Check whether two TyConApps are the same; if the number of arguments
+-- are different, just checks the common prefix of arguments.
+tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool
+tcEqTyConApps tc1 args1 tc2 args2
+  = tc1 == tc2 &&
+    and (zipWith tcEqTypeNoKindCheck args1 args2)
+    -- No kind check necessary: if both arguments are well typed, then
+    -- any difference in the kinds of later arguments would show up
+    -- as differences in earlier (dependent) arguments
 
 -- | Real worker for 'tcEqType'. No kind check!
 tc_eq_type :: Bool          -- ^ True <=> do not expand type synonyms
@@ -2114,18 +2147,6 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of
                         Just (tc, _) -> uniq == getUnique tc
                         Nothing      -> False
 
--- | Does the given tyvar appear at the head of a chain of applications
---     (a t1 ... tn)
-isTyVarHead :: TcTyVar -> TcType -> Bool
-isTyVarHead tv (TyVarTy tv')   = tv == tv'
-isTyVarHead tv (AppTy fun _)   = isTyVarHead tv fun
-isTyVarHead tv (CastTy ty _)   = isTyVarHead tv ty
-isTyVarHead _ (TyConApp {})    = False
-isTyVarHead _  (LitTy {})      = False
-isTyVarHead _  (ForAllTy {})   = False
-isTyVarHead _  (FunTy {})      = False
-isTyVarHead _  (CoercionTy {}) = False
-
 
 {- Note [AppTy and ReprEq]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2147,24 +2168,6 @@ isRigidTy ty
   | otherwise                               = False
 
 
--- | Is this type *almost function-free*? See Note [Almost function-free]
--- in "GHC.Tc.Types"
-isAlmostFunctionFree :: TcType -> Bool
-isAlmostFunctionFree ty | Just ty' <- tcView ty = isAlmostFunctionFree ty'
-isAlmostFunctionFree (TyVarTy {})    = True
-isAlmostFunctionFree (AppTy ty1 ty2) = isAlmostFunctionFree ty1 &&
-                                       isAlmostFunctionFree ty2
-isAlmostFunctionFree (TyConApp tc args)
-  | isTypeFamilyTyCon tc = False
-  | otherwise            = all isAlmostFunctionFree args
-isAlmostFunctionFree (ForAllTy bndr _) = isAlmostFunctionFree (binderType bndr)
-isAlmostFunctionFree (FunTy _ w ty1 ty2) = isAlmostFunctionFree w &&
-                                           isAlmostFunctionFree ty1 &&
-                                           isAlmostFunctionFree ty2
-isAlmostFunctionFree (LitTy {})        = True
-isAlmostFunctionFree (CastTy ty _)     = isAlmostFunctionFree ty
-isAlmostFunctionFree (CoercionTy {})   = True
-
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs
index 4b0a5f8fdd62d3f79d80a93f251d2414340cc4c6..3529f598f8f7e1033f8bee33b4e9cd2ffddedc0e 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs
+++ b/compiler/GHC/Tc/Utils/Unify.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE DeriveFunctor       #-}
+{-# LANGUAGE MultiWayIf          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections       #-}
 
@@ -36,7 +37,8 @@ module GHC.Tc.Utils.Unify (
   matchExpectedFunKind,
   matchActualFunTySigma, matchActualFunTysRho,
 
-  metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..)
+  metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..),
+  checkTyVarEq, checkTyFamEq, checkTypeEq, AreTypeFamiliesOK(..)
 
   ) where
 
@@ -73,6 +75,7 @@ import GHC.Utils.Misc
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 
+import GHC.Exts      ( inline )
 import Control.Monad
 import Control.Arrow ( second )
 
@@ -949,7 +952,7 @@ buildTvImplication skol_info skol_tvs tclvl wanted
 
        ; return (implic { ic_tclvl     = tclvl
                         , ic_skols     = skol_tvs
-                        , ic_no_eqs    = True
+                        , ic_given_eqs = NoGivenEqs
                         , ic_wanted    = wanted
                         , ic_binds     = ev_binds
                         , ic_info      = skol_info }) }
@@ -1431,7 +1434,8 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2
   where
     go dflags cur_lvl
       | canSolveByUnification cur_lvl tv1 ty2
-      , MTVU_OK ty2' <- metaTyVarUpdateOK dflags tv1 ty2
+           -- See Note [Prevent unification with type families] about the NoTypeFamilies:
+      , MTVU_OK ty2' <- metaTyVarUpdateOK dflags NoTypeFamilies tv1 ty2
       = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1)
            ; traceTc "uUnfilledVar2 ok" $
              vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)
@@ -1498,20 +1502,19 @@ lhsPriority tv
       RuntimeUnk  -> 0
       SkolemTv {} -> 0
       MetaTv { mtv_info = info } -> case info of
-                                     FlatSkolTv   -> 1
-                                     TyVarTv      -> 2
-                                     TauTv        -> 3
-                                     FlatMetaTv   -> 4
-                                     RuntimeUnkTv -> 5
+                                     CycleBreakerTv -> 0
+                                     TyVarTv        -> 1
+                                     TauTv          -> 2
+                                     RuntimeUnkTv   -> 3
 
 {- Note [TyVar/TyVar orientation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)?
+Given (a ~ b), should we orient the CEqCan as (a~b) or (b~a)?
 This is a surprisingly tricky question! This is invariant (TyEq:TV).
 
-The question is answered by swapOverTyVars, which is use
+The question is answered by swapOverTyVars, which is used
   - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1
-  - in the constraint solver, in GHC.Tc.Solver.Canonical.canEqTyVarHomo
+  - in the constraint solver, in GHC.Tc.Solver.Canonical.canEqCanLHS2
 
 First note: only swap if you have to!
    See Note [Avoid unnecessary swaps]
@@ -1531,25 +1534,23 @@ So we look for a positive reason to swap, using a three-step test:
         looks for meta tyvars on the left
 
   Tie-breaking rules for MetaTvs:
-  - FlatMetaTv = 4: always put on the left.
-        See Note [Fmv Orientation Invariant]
+  - CycleBreakerTv: This is essentially a stand-in for another type;
+       it's untouchable and should have the same priority as a skolem: 0.
 
-        NB: FlatMetaTvs always have the current level, never an
-        outer one.  So nothing can be deeper than a FlatMetaTv.
+  - TyVarTv: These can unify only with another tyvar, but we can't unify
+       a TyVarTv with a TauTv, because then the TyVarTv could (transitively)
+       get a non-tyvar type. So give these a low priority: 1.
 
-  - TauTv = 3: if we have  tyv_tv ~ tau_tv,
-       put tau_tv on the left because there are fewer
-       restrictions on updating TauTvs.  Or to say it another
-       way, then we won't lose the TyVarTv flag
+  - TauTv: This is the common case; we want these on the left so that they
+       can be written to: 2.
 
-  - TyVarTv = 2: remember, flat-skols are *only* updated by
-       the unflattener, never unified, so TyVarTvs come next
-
-  - FlatSkolTv = 1: put on the left in preference to a SkolemTv.
-       See Note [Eliminate flat-skols]
+  - RuntimeUnkTv: These aren't really meta-variables used in type inference,
+       but just a convenience in the implementation of the GHCi debugger.
+       Eagerly write to these: 3. See Note [RuntimeUnkTv] in
+       GHC.Runtime.Heap.Inspect.
 
 * Names. If the level and priority comparisons are all
-  equal, try to eliminate a TyVars with a System Name in
+  equal, try to eliminate a TyVar with a System Name in
   favour of ones with a Name derived from a user type signature
 
 * Age.  At one point in the past we tried to break any remaining
@@ -1602,64 +1603,6 @@ Wanteds and Givens, but either way, deepest wins!  Simple.
 See #15009 for an further analysis of why "deepest on the left"
 is a good plan.
 
-Note [Fmv Orientation Invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   * We always orient a constraint
-        fmv ~ alpha
-     with fmv on the left, even if alpha is
-     a touchable unification variable
-
-Reason: doing it the other way round would unify alpha:=fmv, but that
-really doesn't add any info to alpha.  But a later constraint alpha ~
-Int might unlock everything.  Comment:9 of #12526 gives a detailed
-example.
-
-WARNING: I've gone to and fro on this one several times.
-I'm now pretty sure that unifying alpha:=fmv is a bad idea!
-So orienting with fmvs on the left is a good thing.
-
-This example comes from IndTypesPerfMerge. (Others include
-T10226, T10009.)
-    From the ambiguity check for
-      f :: (F a ~ a) => a
-    we get:
-          [G] F a ~ a
-          [WD] F alpha ~ alpha, alpha ~ a
-
-    From Givens we get
-          [G] F a ~ fsk, fsk ~ a
-
-    Now if we flatten we get
-          [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a
-
-    Now, if we unified alpha := fmv, we'd get
-          [WD] F fmv ~ fmv, [WD] fmv ~ a
-    And now we are stuck.
-
-So instead the Fmv Orientation Invariant puts the fmv on the
-left, giving
-      [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a
-
-    Now we get alpha:=a, and everything works out
-
-Note [Eliminate flat-skols]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have  [G] Num (F [a])
-then we flatten to
-     [G] Num fsk
-     [G] F [a] ~ fsk
-where fsk is a flatten-skolem (FlatSkolTv). Suppose we have
-      type instance F [a] = a
-then we'll reduce the second constraint to
-     [G] a ~ fsk
-and then replace all uses of 'a' with fsk.  That's bad because
-in error messages instead of saying 'a' we'll say (F [a]).  In all
-places, including those where the programmer wrote 'a' in the first
-place.  Very confusing!  See #7862.
-
-Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate
-the fsk.
-
 Note [Avoid unnecessary swaps]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If we swap without actually improving matters, we can get an infinite loop.
@@ -1734,8 +1677,11 @@ It would be lovely in the future to revisit this problem and remove this
 extra, unnecessary check. But we retain it for now as it seems to work
 better in practice.
 
-Note [Refactoring hazard: checkTauTvUpdate]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Revisited in Nov '20, along with removing flattening variables. Problem
+is still present, and the solution (NoTypeFamilies) is still the same.
+
+Note [Refactoring hazard: metaTyVarUpdateOK]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 I (Richard E.) have a sad story about refactoring this code, retained here
 to prevent others (or a future me!) from falling into the same traps.
 
@@ -1957,7 +1903,7 @@ occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult ()
 --   a) the given variable occurs in the given type.
 --   b) there is a forall in the type (unless we have -XImpredicativeTypes)
 occCheckForErrors dflags tv ty
-  = case mtvu_check dflags True tv ty of
+  = case checkTyVarEq dflags YesTypeFamilies tv ty of
       MTVU_OK _        -> MTVU_OK ()
       MTVU_Bad         -> MTVU_Bad
       MTVU_HoleBlocker -> MTVU_HoleBlocker
@@ -1966,16 +1912,24 @@ occCheckForErrors dflags tv ty
                             Just _  -> MTVU_OK ()
 
 ----------------
+data AreTypeFamiliesOK = YesTypeFamilies
+                       | NoTypeFamilies
+                       deriving Eq
+
+instance Outputable AreTypeFamiliesOK where
+  ppr YesTypeFamilies = text "YesTypeFamilies"
+  ppr NoTypeFamilies  = text "NoTypeFamilies"
+
 metaTyVarUpdateOK :: DynFlags
+                  -> AreTypeFamiliesOK   -- allow type families in RHS?
                   -> TcTyVar             -- tv :: k1
                   -> TcType              -- ty :: k2
                   -> MetaTyVarUpdateResult TcType        -- possibly-expanded ty
 -- (metaTyVarUpdateOK tv ty)
 -- Checks that the equality tv~ty is OK to be used to rewrite
--- other equalities.  Equivalently, checks the conditions for CTyEqCan
+-- other equalities.  Equivalently, checks the conditions for CEqCan
 --       (a) that tv doesn't occur in ty (occurs check)
---       (b) that ty does not have any foralls
---           (in the impredicative case), or type functions
+--       (b) that ty does not have any foralls or (perhaps) type functions
 --       (c) that ty does not have any blocking coercion holes
 --           See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical"
 --
@@ -2000,12 +1954,10 @@ metaTyVarUpdateOK :: DynFlags
 -- we return Nothing, leaving it to the later constraint simplifier to
 -- sort matters out.
 --
--- See Note [Refactoring hazard: checkTauTvUpdate]
+-- See Note [Refactoring hazard: metaTyVarUpdateOK]
 
-metaTyVarUpdateOK dflags tv ty
-  = case mtvu_check dflags False tv ty of
-         -- False <=> type families not ok
-         -- See Note [Prevent unification with type families]
+metaTyVarUpdateOK dflags ty_fam_ok tv ty
+  = case checkTyVarEq dflags ty_fam_ok tv ty of
       MTVU_OK _        -> MTVU_OK ty
       MTVU_Bad         -> MTVU_Bad          -- forall, predicate, type function
       MTVU_HoleBlocker -> MTVU_HoleBlocker  -- coercion hole
@@ -2013,20 +1965,40 @@ metaTyVarUpdateOK dflags tv ty
                             Just expanded_ty -> MTVU_OK expanded_ty
                             Nothing          -> MTVU_Occurs
 
-mtvu_check :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult ()
--- Checks the invariants for CTyEqCan.   In particular:
+checkTyVarEq :: DynFlags -> AreTypeFamiliesOK -> TcTyVar -> TcType -> MetaTyVarUpdateResult ()
+checkTyVarEq dflags ty_fam_ok tv ty
+  = inline checkTypeEq dflags ty_fam_ok (TyVarLHS tv) ty
+    -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away
+
+checkTyFamEq :: DynFlags
+             -> TyCon     -- type function
+             -> [TcType]  -- args, exactly saturated
+             -> TcType    -- RHS
+             -> MetaTyVarUpdateResult ()
+checkTyFamEq dflags fun_tc fun_args ty
+  = inline checkTypeEq dflags YesTypeFamilies (TyFamLHS fun_tc fun_args) ty
+    -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away
+
+checkTypeEq :: DynFlags -> AreTypeFamiliesOK -> CanEqLHS -> TcType
+            -> MetaTyVarUpdateResult ()
+-- Checks the invariants for CEqCan.   In particular:
 --   (a) a forall type (forall a. blah)
 --   (b) a predicate type (c => ty)
 --   (c) a type family; see Note [Prevent unification with type families]
 --   (d) a blocking coercion hole
---   (e) an occurrence of the type variable (occurs check)
+--   (e) an occurrence of the LHS (occurs check)
 --
 -- For (a), (b), and (c) we check only the top level of the type, NOT
 -- inside the kinds of variables it mentions.  For (d) we look deeply
--- in coercions, and for (e) we do look in the kinds of course.
-
-mtvu_check dflags ty_fam_ok tv ty
-  = fast_check ty
+-- in coercions when the LHS is a tyvar (but skip coercions for type family
+-- LHSs), and for (e) see Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.
+--
+-- checkTypeEq is called from
+--    * checkTyFamEq, checkTyVarEq (which inline it to specialise away the
+--      case-analysis on 'lhs'
+--    * checkEqCanLHSFinish, which does not know the form of 'lhs'
+checkTypeEq dflags ty_fam_ok lhs ty
+  = go ty
   where
     ok :: MetaTyVarUpdateResult ()
     ok = MTVU_OK ()
@@ -2035,53 +2007,82 @@ mtvu_check dflags ty_fam_ok tv ty
     -- unification variables that can unify with a polytype
     -- or a TyCon that would usually be disallowed by bad_tc
     -- See Note [RuntimeUnkTv] in GHC.Runtime.Heap.Inspect
-    ghci_tv = case tcTyVarDetails tv of
-                MetaTv { mtv_info = RuntimeUnkTv } -> True
-                _                                  -> False
-
-    fast_check :: TcType -> MetaTyVarUpdateResult ()
-    fast_check (TyVarTy tv')
-      | tv == tv' = MTVU_Occurs
-      | otherwise = fast_check_occ (tyVarKind tv')
-           -- See Note [Occurrence checking: look inside kinds]
-           -- in GHC.Core.Type
-
-    fast_check (TyConApp tc tys)
-      | bad_tc tc, not ghci_tv = MTVU_Bad
-      | otherwise              = mapM fast_check tys >> ok
-    fast_check (LitTy {})      = ok
-    fast_check (FunTy{ft_af = af, ft_mult = w, ft_arg = a, ft_res = r})
+    ghci_tv
+      | TyVarLHS tv <- lhs
+      , MetaTv { mtv_info = RuntimeUnkTv } <- tcTyVarDetails tv
+      = True
+
+      | otherwise
+      = False
+
+    go :: TcType -> MetaTyVarUpdateResult ()
+    go (TyVarTy tv')           = go_tv tv'
+    go (TyConApp tc tys)       = go_tc tc tys
+    go (LitTy {})              = ok
+    go (FunTy{ft_af = af, ft_mult = w, ft_arg = a, ft_res = r})
       | InvisArg <- af
       , not ghci_tv            = MTVU_Bad
-      | otherwise              = fast_check w   >> fast_check a >> fast_check r
-    fast_check (AppTy fun arg) = fast_check fun >> fast_check arg
-    fast_check (CastTy ty co)  = fast_check ty  >> fast_check_co co
-    fast_check (CoercionTy co) = fast_check_co co
-    fast_check (ForAllTy (Bndr tv' _) ty)
+      | otherwise              = go w   >> go a >> go r
+    go (AppTy fun arg) = go fun >> go arg
+    go (CastTy ty co)  = go ty  >> go_co co
+    go (CoercionTy co) = go_co co
+    go (ForAllTy (Bndr tv' _) ty)
        | not ghci_tv = MTVU_Bad
-       | tv == tv'   = ok
-       | otherwise = do { fast_check_occ (tyVarKind tv')
-                        ; fast_check_occ ty }
-       -- Under a forall we look only for occurrences of
-       -- the type variable
+       | otherwise   = case lhs of
+           TyVarLHS tv | tv == tv' -> ok
+                       | otherwise -> do { go_occ tv (tyVarKind tv')
+                                         ; go ty }
+           _                       -> go ty
+
+    go_tv :: TcTyVar -> MetaTyVarUpdateResult ()
+      -- this slightly peculiar way of defining this means
+      -- we don't have to evaluate this `case` at every variable
+      -- occurrence
+    go_tv = case lhs of
+      TyVarLHS tv -> \ tv' -> if tv == tv'
+                              then MTVU_Occurs
+                              else go_occ tv (tyVarKind tv')
+      TyFamLHS {} -> \ _tv' -> ok
+           -- See Note [Occurrence checking: look inside kinds] in GHC.Core.Type
 
      -- For kinds, we only do an occurs check; we do not worry
      -- about type families or foralls
      -- See Note [Checking for foralls]
-    fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs
-                     | otherwise                        = ok
+    go_occ tv k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs
+                | otherwise                        = ok
+
+    go_tc :: TyCon -> [TcType] -> MetaTyVarUpdateResult ()
+      -- this slightly peculiar way of defining this means
+      -- we don't have to evaluate this `case` at every tyconapp
+    go_tc = case lhs of
+      TyVarLHS {} -> \ tc tys ->
+        if | good_tc tc -> mapM go tys >> ok
+           | otherwise  -> MTVU_Bad
+      TyFamLHS fam_tc fam_args -> \ tc tys ->
+        if | tcEqTyConApps fam_tc fam_args tc tys -> MTVU_Occurs
+           | good_tc tc                           -> mapM go tys >> ok
+           | otherwise                            -> MTVU_Bad
+
 
      -- no bother about impredicativity in coercions, as they're
      -- inferred
-    fast_check_co co | not (gopt Opt_DeferTypeErrors dflags)
-                     , badCoercionHoleCo co            = MTVU_HoleBlocker
-        -- Wrinkle (4b) in "GHC.Tc.Solver.Canonical" Note [Equalities with incompatible kinds]
-
-                     | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs
-                     | otherwise                       = ok
-
-    bad_tc :: TyCon -> Bool
-    bad_tc tc
-      | not (isTauTyCon tc)                  = True
-      | not (ty_fam_ok || isFamFreeTyCon tc) = True
-      | otherwise                            = False
+    go_co co | not (gopt Opt_DeferTypeErrors dflags)
+             , hasCoercionHoleCo co
+             = MTVU_HoleBlocker  -- Wrinkle (2) in GHC.Tc.Solver.Canonical
+        -- See GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds]
+        -- Wrinkle (2) about this case in general, Wrinkle (4b) about the check for
+        -- deferred type errors.
+
+             | TyVarLHS tv <- lhs
+             , tv `elemVarSet` tyCoVarsOfCo co
+             = MTVU_Occurs
+
+        -- Don't check coercions for type families; see commentary at top of function
+             | otherwise
+             = ok
+
+    good_tc :: TyCon -> Bool
+    good_tc
+      | ghci_tv   = \ _tc -> True
+      | otherwise = \ tc  -> isTauTyCon tc &&
+                             (ty_fam_ok == YesTypeFamilies || isFamFreeTyCon tc)
diff --git a/compiler/GHC/Types/Unique/DFM.hs b/compiler/GHC/Types/Unique/DFM.hs
index 56107a6087d5cb06dae60fd681ad94872641ba53..ef78dbe6af58a6068770bc632e452091a38a0790 100644
--- a/compiler/GHC/Types/Unique/DFM.hs
+++ b/compiler/GHC/Types/Unique/DFM.hs
@@ -15,8 +15,12 @@ is not deterministic.
 -}
 
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# OPTIONS_GHC -Wall #-}
 
@@ -38,6 +42,7 @@ module GHC.Types.Unique.DFM (
         adjustUDFM_Directly,
         alterUDFM,
         mapUDFM,
+        mapMaybeUDFM,
         plusUDFM,
         plusUDFM_C,
         lookupUDFM, lookupUDFM_Directly,
@@ -121,7 +126,7 @@ data TaggedVal val =
   TaggedVal
     val
     {-# UNPACK #-} !Int -- ^ insertion time
-  deriving (Data, Functor)
+  deriving stock (Data, Functor, Foldable, Traversable)
 
 taggedFst :: TaggedVal val -> val
 taggedFst (TaggedVal v _) = v
@@ -399,6 +404,10 @@ alterUDFM f (UDFM m i) k =
 mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
 mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i
 
+mapMaybeUDFM :: forall elt1 elt2 key.
+                (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2
+mapMaybeUDFM f (UDFM m i) = UDFM (M.mapMaybe (traverse f) m) i
+
 anyUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool
 anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m
 
diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst
index da0461f982db0cbfc08498a7eae76f6674dfff00..30a58175f4440ea086bc97c0fd6080cb61dc5017 100644
--- a/docs/users_guide/9.2.1-notes.rst
+++ b/docs/users_guide/9.2.1-notes.rst
@@ -44,6 +44,10 @@ Compiler
   that the compiler automatically insert cost-centres on all call-sites of
   the named function.
 
+- There is a significant refactoring in the solver; any type-checker plugins
+  will have to be updated, as GHC no longer uses flattening skolems or
+  flattening metavariables.
+  
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/expected-undocumented-flags.txt b/docs/users_guide/expected-undocumented-flags.txt
index 23b5a4abe7bbeccae5efff86da50ed099897df41..75a433189c3200406f97d4bc21692a4d14cae190 100644
--- a/docs/users_guide/expected-undocumented-flags.txt
+++ b/docs/users_guide/expected-undocumented-flags.txt
@@ -57,7 +57,6 @@
 -fextended-default-rules
 -fffi
 -ffi
--fflat-cache
 -ffloat-all-lams
 -ffloat-lam-args
 -ffrontend-opt
diff --git a/docs/users_guide/exts/type_families.rst b/docs/users_guide/exts/type_families.rst
index 3c09e63a1481e52eac6dbde70ec2c581aec39a71..4843e35a80533d95d3de8d13519347d69740be96 100644
--- a/docs/users_guide/exts/type_families.rst
+++ b/docs/users_guide/exts/type_families.rst
@@ -581,6 +581,51 @@ If the option :extension:`UndecidableInstances` is passed to the compiler, the
 above restrictions are not enforced and it is on the programmer to ensure
 termination of the normalisation of type families during type inference.
 
+Reducing type family applications
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+.. ghc-flag:: -ffamily-application-cache
+    :shortdesc: Use a cache when reducing type family applications
+    :type: dynamic
+    :reverse: -fno-family-application-cache
+    :category:
+
+    The flag :ghc-flag:`-ffamily-application-cache` (on by default) instructs
+    GHC to use a cache when reducing type family applications. In most cases,
+    this will speed up compilation. The use of this flag will not affect
+    runtime behaviour.
+
+When GHC encounters a type family application (like ``F Int a``) in a program,
+it must often reduce it in order to complete type checking. Here is a simple
+example::
+
+  type family F a where
+    F Int            = Bool
+    F (Maybe Double) = Char
+
+  g :: F Int -> Bool
+  g = not
+
+Despite the fact that ``g``\'s type mentions ``F Int``, GHC must recognize that
+``g``\'s argument really has type ``Bool``. This is done by *reducing* ``F Int``
+to become ``Bool``. Sometimes, there is not enough information to reduce a type
+family application; we say such an application is *stuck*. Continuing this example,
+an occurrence of ``F (Maybe a)`` (for some type variable ``a``) would be stuck, as
+no equation applies.
+
+During type checking, GHC uses heuristics to determine which type family application
+to reduce next; there is no predictable ordering among different type family applications.
+The non-determinism rarely matters in practice. In most programs, type family reduction
+terminates, and so these choices are immaterial. However, if a type family application
+does not terminate, it is possible that type-checking may unpredictably diverge. (GHC
+will always take the same path for a given source program, but small changes in that
+source program may induce GHC to take a different path. Compiling a given, unchanged
+source program is still deterministic.)
+
+In order to speed up type family reduction, GHC normally uses a cache, remembering what
+type family applications it has previously reduced. This feature can be disabled with
+:ghc-flag:`-fno-family-application-cache`.
+
 .. _type-wildcards-lhs:
 
 Wildcards on the LHS of data and type family instances
diff --git a/testsuite/tests/gadt/T3169.stderr b/testsuite/tests/gadt/T3169.stderr
index 5770e03c7072b64bf46f98137d41dac632a9a5d8..3a5fc99fb33745eb45489b45e47ca0e8df87f64c 100644
--- a/testsuite/tests/gadt/T3169.stderr
+++ b/testsuite/tests/gadt/T3169.stderr
@@ -1,17 +1,20 @@
 
-T3169.hs:13:22: error:
+T3169.hs:13:13: error:
     • Couldn't match type ‘elt’ with ‘Map b elt’
-      Expected: Map a (Map b elt)
-        Actual: Map (a, b) elt
+      Expected: Maybe (Map b elt)
+        Actual: Maybe elt
       ‘elt’ is a rigid type variable bound by
         the type signature for:
           lookup :: forall elt. (a, b) -> Map (a, b) elt -> Maybe elt
         at T3169.hs:12:3-8
-    • In the second argument of ‘lookup’, namely ‘m’
-      In the expression: lookup a m :: Maybe (Map b elt)
+    • In the expression: lookup a m :: Maybe (Map b elt)
       In the expression:
         case lookup a m :: Maybe (Map b elt) of {
           Just (m2 :: Map b elt) -> lookup b m2 :: Maybe elt }
+      In an equation for ‘lookup’:
+          lookup (a, b) (m :: Map (a, b) elt)
+            = case lookup a m :: Maybe (Map b elt) of {
+                Just (m2 :: Map b elt) -> lookup b m2 :: Maybe elt }
     • Relevant bindings include
         m :: Map (a, b) elt (bound at T3169.hs:12:17)
         b :: b (bound at T3169.hs:12:13)
diff --git a/testsuite/tests/gadt/T7293.stderr b/testsuite/tests/gadt/T7293.stderr
index 87856d4009bf8d35256f8866f271ba5ac9b758c8..5625ff01c572fa9b79a2ef2aec001b37463f96c5 100644
--- a/testsuite/tests/gadt/T7293.stderr
+++ b/testsuite/tests/gadt/T7293.stderr
@@ -4,7 +4,7 @@ T7293.hs:26:1: error: [-Woverlapping-patterns (in -Wdefault), -Werror=overlappin
     In an equation for ‘nth’: nth Nil _ = ...
 
 T7293.hs:26:5: error: [-Winaccessible-code (in -Wdefault), -Werror=inaccessible-code]
-    • Couldn't match type ‘'True’ with ‘'False’
+    • Couldn't match type ‘'False’ with ‘'True’
       Inaccessible code in
         a pattern with constructor: Nil :: forall a. Vec a 'Zero,
         in an equation for ‘nth’
diff --git a/testsuite/tests/gadt/T7294.stderr b/testsuite/tests/gadt/T7294.stderr
index d7b53ee9e2bb05e14eb256a561a3bf0b06a59b82..f694af8d0c28bc1c5f4b118c5a8b031b11e4a5d8 100644
--- a/testsuite/tests/gadt/T7294.stderr
+++ b/testsuite/tests/gadt/T7294.stderr
@@ -4,7 +4,7 @@ T7294.hs:27:1: warning: [-Woverlapping-patterns (in -Wdefault)]
     In an equation for ‘nth’: nth Nil _ = ...
 
 T7294.hs:27:5: warning: [-Winaccessible-code (in -Wdefault)]
-    • Couldn't match type ‘'True’ with ‘'False’
+    • Couldn't match type ‘'False’ with ‘'True’
       Inaccessible code in
         a pattern with constructor: Nil :: forall a. Vec a 'Zero,
         in an equation for ‘nth’
diff --git a/testsuite/tests/indexed-types/should_compile/CEqCanOccursCheck.hs b/testsuite/tests/indexed-types/should_compile/CEqCanOccursCheck.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f3c9918847679b27738dd5c9bee15f9ef642ea1d
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/CEqCanOccursCheck.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE TypeFamilies #-}
+-- Important: no AllowAmbiguousTypes
+
+module CEqCanOccursCheck where
+
+type family F a where
+  F Bool = Bool
+type family G a b where
+  G a a = a
+
+{-
+[W] F alpha ~ alpha
+[W] F alpha ~ beta
+[W] G alpha beta ~ Int
+-}
+
+foo :: (F a ~ a, F a ~ b) => G a b -> ()
+foo _ = ()
+
+bar :: ()
+bar = foo True
+
+{-
+[G] F a ~ a
+[W] F alpha ~ alpha
+[W] F alpha ~ F a
+-}
+
+notAmbig :: F a ~ a => F a
+notAmbig = undefined
diff --git a/testsuite/tests/indexed-types/should_compile/GivenLoop.hs b/testsuite/tests/indexed-types/should_compile/GivenLoop.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d8ece8cb267635e30d01a42bfe87fabc882c1ea6
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/GivenLoop.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module GivenLoop where
+
+type family UnMaybe a where
+  UnMaybe (Maybe b) = b
+
+class C c where
+  meth :: c
+
+instance C (Maybe d) where
+  meth = Nothing
+
+f :: (e ~ Maybe (UnMaybe e)) => e
+f = meth
diff --git a/testsuite/tests/indexed-types/should_compile/Simple13.hs b/testsuite/tests/indexed-types/should_compile/Simple13.hs
index 9e463e8e052c3c854751e55c40ccebfdf368e039..d4e39a933570a5bb377242675bbe44d52181940f 100644
--- a/testsuite/tests/indexed-types/should_compile/Simple13.hs
+++ b/testsuite/tests/indexed-types/should_compile/Simple13.hs
@@ -21,7 +21,7 @@ foo p = same p (mkf p)
   [G] g : a ~ [F a]
   [W] w : a ~ [F a]
 
----> 
+--->
   g' = g;[x]                g'=aq4
   [G] g'  : a ~ [fsk]       g=aqW
   [W] x : F a ~ fsk         x=aq3
@@ -36,7 +36,7 @@ foo p = same p (mkf p)
       w = g' ; w2
   [W] w2 : [fsk] ~ [F a]
 
-  --> decompose 
+  --> decompose
        w2 = [w3]
    [W] w3 : fsk ~ F a
 
@@ -44,5 +44,5 @@ foo p = same p (mkf p)
 
 cycle is
    aq3 = Sym (F aq4) ; aq5    x = Sym (F g') ; x2
-   aq4 = apw ; aq3            g' = 
+   aq4 = apw ; aq3            g' =
 -}
diff --git a/testsuite/tests/indexed-types/should_compile/T18875.hs b/testsuite/tests/indexed-types/should_compile/T18875.hs
new file mode 100644
index 0000000000000000000000000000000000000000..60fd1cb86afcfcc6a393aaebfeb7d4e4393856fa
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T18875.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module T18875 where
+
+-- This exercises Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical
+
+type family G a b where
+  G (Maybe c) d = d
+
+h :: (e ~ Maybe (G e f)) => e -> f
+h (Just x) = x
diff --git a/testsuite/tests/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr
index 20032b6ad44ab2a88e25f534ff8b09d4e5d56805..a860b3c76b218c97a696d94de770e17324962897 100644
--- a/testsuite/tests/indexed-types/should_compile/T3017.stderr
+++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr
@@ -4,7 +4,7 @@ TYPE SIGNATURES
   insert :: forall c. Coll c => Elem c -> c -> c
   test2 ::
     forall {c} {a} {b}.
-    (Coll c, Num a, Num b, Elem c ~ (a, b)) =>
+    (Elem c ~ (a, b), Coll c, Num a, Num b) =>
     c -> c
 TYPE CONSTRUCTORS
   class Coll{1} :: * -> Constraint
@@ -20,4 +20,4 @@ CLASS INSTANCES
 FAMILY INSTANCES
   type instance Elem (ListColl a) = a -- Defined at T3017.hs:13:9
 Dependent modules: []
-Dependent packages: [base-4.13.0.0, ghc-bignum-1.0, ghc-prim-0.7.0]
+Dependent packages: [base-4.15.0.0, ghc-bignum-1.0, ghc-prim-0.7.0]
diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T
index 8b3dd5e866a41c4e3d38224bc217762c39c1ec10..285619f570adbc4c232d8907b91cd5b627453f4b 100644
--- a/testsuite/tests/indexed-types/should_compile/all.T
+++ b/testsuite/tests/indexed-types/should_compile/all.T
@@ -297,3 +297,6 @@ test('T17405', normal, multimod_compile, ['T17405c', '-v0'])
 test('T17923', normal, compile, [''])
 test('T18065', normal, compile, ['-O'])
 test('T18809', normal, compile, ['-O'])
+test('CEqCanOccursCheck', normal, compile, [''])
+test('GivenLoop', normal, compile, [''])
+test('T18875', normal, compile, [''])
diff --git a/testsuite/tests/indexed-types/should_fail/ExpandTFs.hs b/testsuite/tests/indexed-types/should_fail/ExpandTFs.hs
new file mode 100644
index 0000000000000000000000000000000000000000..7a0915d2984bd4f7109ed8335fc70a14868c8369
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/ExpandTFs.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeFamilies, DataKinds #-}
+
+module ExpandTFs where
+
+-- from https://mail.haskell.org/pipermail/ghc-devs/2020-November/019366.html,
+-- where it is requested to expand (Foo Int) in the error message
+
+type family Foo a where Foo Int = String
+type family Bar a :: Maybe (Foo Int) where Bar a = '()
diff --git a/testsuite/tests/indexed-types/should_fail/ExpandTFs.stderr b/testsuite/tests/indexed-types/should_fail/ExpandTFs.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..ff2daf734f61721d4816529a471b949da9cc7db8
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/ExpandTFs.stderr
@@ -0,0 +1,6 @@
+
+ExpandTFs.hs:9:52: error:
+    • Couldn't match kind ‘()’ with ‘Maybe String’
+      Expected kind ‘Maybe (Foo Int)’, but ‘'()’ has kind ‘()’
+    • In the type ‘'()’
+      In the type family declaration for ‘Bar’
diff --git a/testsuite/tests/indexed-types/should_fail/Simple13.stderr b/testsuite/tests/indexed-types/should_fail/Simple13.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..129ae473c506f7a8b5b576985b62f3e6a3f35fff
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/Simple13.stderr
@@ -0,0 +1,13 @@
+
+Simple13.hs:17:17: error:
+    • Couldn't match type: F [F a]
+                     with: F a
+      Expected: a
+        Actual: [F a]
+      NB: ‘F’ is a non-injective type family
+    • In the second argument of ‘same’, namely ‘(mkf p)’
+      In the expression: same p (mkf p)
+      In an equation for ‘foo’: foo p = same p (mkf p)
+    • Relevant bindings include
+        p :: a (bound at Simple13.hs:17:5)
+        foo :: a -> a (bound at Simple13.hs:17:1)
diff --git a/testsuite/tests/indexed-types/should_fail/T13784.stderr b/testsuite/tests/indexed-types/should_fail/T13784.stderr
index 11b1a188f2f65f98d16ec216242492a94136179e..04156ccdc98bf1f7c1676282d3532a1287d6397a 100644
--- a/testsuite/tests/indexed-types/should_fail/T13784.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T13784.stderr
@@ -15,7 +15,7 @@ T13784.hs:29:28: error:
 
 T13784.hs:33:24: error:
     • Couldn't match type: Product (a : as0)
-                     with: (b, Product (Divide b (a : as)))
+                     with: (b, Product (a : Divide b as))
       Expected: (b, Product (Divide b (a : as)))
         Actual: Product (a1 : as0)
     • In the expression: a :* divide as
diff --git a/testsuite/tests/indexed-types/should_fail/T14369.stderr b/testsuite/tests/indexed-types/should_fail/T14369.stderr
index d31a77b2facb1aa1c076feed1621c8f47dd4fad2..a3a9eb73f73d56513310d2bbcff9e5cbbb6070c2 100644
--- a/testsuite/tests/indexed-types/should_fail/T14369.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T14369.stderr
@@ -1,9 +1,20 @@
 
 T14369.hs:29:5: error:
-    • Couldn't match type: Demote a
-                     with: Demote a1
+    • Couldn't match type ‘a’ with ‘a1’
       Expected: Sing x -> Maybe (Demote a1)
         Actual: Sing x -> Demote (Maybe a)
+      ‘a’ is a rigid type variable bound by
+        the type signature for:
+          f :: forall {a} (x :: forall a1. Maybe a1) a1.
+               SingKind a1 =>
+               Sing x -> Maybe (Demote a1)
+        at T14369.hs:28:1-80
+      ‘a1’ is a rigid type variable bound by
+        the type signature for:
+          f :: forall {a} (x :: forall a1. Maybe a1) a1.
+               SingKind a1 =>
+               Sing x -> Maybe (Demote a1)
+        at T14369.hs:28:1-80
     • In the expression: fromSing
       In an equation for ‘f’: f = fromSing
     • Relevant bindings include
diff --git a/testsuite/tests/indexed-types/should_fail/T2544.stderr b/testsuite/tests/indexed-types/should_fail/T2544.stderr
index 40409c10cce93281d57ecebdb5c8d23e6e18735b..721267e75d6407dd07fdd19046d36116af3bd8eb 100644
--- a/testsuite/tests/indexed-types/should_fail/T2544.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T2544.stderr
@@ -1,13 +1,13 @@
 
-T2544.hs:19:18: error:
-    • Couldn't match type: IxMap i0
-                     with: IxMap l
-      Expected: IxMap l [Int]
-        Actual: IxMap i0 [Int]
+T2544.hs:19:12: error:
+    • Couldn't match type: IxMap i1
+                     with: IxMap r
+      Expected: IxMap (l :|: r) [Int]
+        Actual: BiApp (IxMap i0) (IxMap i1) [Int]
       NB: ‘IxMap’ is a non-injective type family
-      The type variable ‘i0’ is ambiguous
-    • In the first argument of ‘BiApp’, namely ‘empty’
-      In the expression: BiApp empty empty
+      The type variable ‘i1’ is ambiguous
+    • In the expression: BiApp empty empty
       In an equation for ‘empty’: empty = BiApp empty empty
+      In the instance declaration for ‘Ix (l :|: r)’
     • Relevant bindings include
         empty :: IxMap (l :|: r) [Int] (bound at T2544.hs:19:4)
diff --git a/testsuite/tests/indexed-types/should_fail/T2627b.stderr b/testsuite/tests/indexed-types/should_fail/T2627b.stderr
index b69883ab888a88d365912f8880d4bb6bb752119b..2db3dd639782bb7a3947ac434cb2f7157dc48e0d 100644
--- a/testsuite/tests/indexed-types/should_fail/T2627b.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T2627b.stderr
@@ -1,6 +1,6 @@
 
 T2627b.hs:20:24: error:
-    • Could not deduce: Dual (Dual b0) ~ b0
+    • Could not deduce: Dual (Dual a0) ~ a0
         arising from a use of ‘conn’
       from the context: (Dual a ~ b, Dual b ~ a)
         bound by the type signature for:
@@ -13,7 +13,12 @@ T2627b.hs:20:24: error:
                    Rd :: forall c d. (c -> Comm d) -> Comm (R c d),
                  in an equation for ‘conn’
         at T2627b.hs:20:7-10
-      The type variable ‘b0’ is ambiguous
+      or from: b ~ W e f
+        bound by a pattern with constructor:
+                   Wr :: forall e f. e -> Comm f -> Comm (W e f),
+                 in an equation for ‘conn’
+        at T2627b.hs:20:14-19
+      The type variable ‘a0’ is ambiguous
     • In the expression: conn undefined undefined
       In an equation for ‘conn’:
           conn (Rd k) (Wr a r) = conn undefined undefined
diff --git a/testsuite/tests/indexed-types/should_fail/T3330c.stderr b/testsuite/tests/indexed-types/should_fail/T3330c.stderr
index 9222e6fffe8473bf227acde95dd76a5d056c0727..3947abddb607e8bbf94a734d37ec935c58e9a181 100644
--- a/testsuite/tests/indexed-types/should_fail/T3330c.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T3330c.stderr
@@ -3,14 +3,14 @@ T3330c.hs:25:43: error:
     • Couldn't match kind ‘*’ with ‘* -> *’
       When matching types
         f1 :: * -> *
-        f1 x :: *
-      Expected: Der ((->) x) (f1 x)
+        Der f1 x :: *
+      Expected: Der ((->) x) (Der f1 x)
         Actual: R f1
     • In the first argument of ‘plug’, namely ‘rf’
       In the first argument of ‘Inl’, namely ‘(plug rf df x)’
       In the expression: Inl (plug rf df x)
     • Relevant bindings include
         x :: x (bound at T3330c.hs:25:29)
-        df :: f1 x (bound at T3330c.hs:25:25)
+        df :: Der f1 x (bound at T3330c.hs:25:25)
         rf :: R f1 (bound at T3330c.hs:25:13)
         plug' :: R f -> Der f x -> x -> f x (bound at T3330c.hs:25:1)
diff --git a/testsuite/tests/indexed-types/should_fail/T4174.stderr b/testsuite/tests/indexed-types/should_fail/T4174.stderr
index ae962edf36f26327988e24123a61426b216a0150..396fab9469cc3af16b5729f8158c80e50ed602d6 100644
--- a/testsuite/tests/indexed-types/should_fail/T4174.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T4174.stderr
@@ -1,9 +1,9 @@
 
 T4174.hs:44:12: error:
-    • Couldn't match type ‘b’ with ‘RtsSpinLock’
+    • Couldn't match type ‘a’ with ‘SmStep’
       Expected: m (Field (Way (GHC6'8 minor) n t p) a b)
         Actual: m (Field (WayOf m) SmStep RtsSpinLock)
-      ‘b’ is a rigid type variable bound by
+      ‘a’ is a rigid type variable bound by
         the type signature for:
           testcase :: forall (m :: * -> *) minor n t p a b.
                       Monad m =>
diff --git a/testsuite/tests/indexed-types/should_fail/T4179.stderr b/testsuite/tests/indexed-types/should_fail/T4179.stderr
index 4665a1a321d1a0bd0bc0b837575b5b0e4506cd28..545c03754d20b967d0c111ce92b75ed5c89514c6 100644
--- a/testsuite/tests/indexed-types/should_fail/T4179.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T4179.stderr
@@ -1,13 +1,13 @@
 
 T4179.hs:26:16: error:
-    • Couldn't match type: A2 (x (A2 (FCon x) -> A3 (FCon x)))
-                     with: A2 (FCon x)
+    • Couldn't match type: A3 (x (A2 (FCon x) -> A3 (FCon x)))
+                     with: A3 (FCon x)
       Expected: x (A2 (FCon x) -> A3 (FCon x))
                 -> A2 (FCon x) -> A3 (FCon x)
         Actual: x (A2 (FCon x) -> A3 (FCon x))
                 -> A2 (x (A2 (FCon x) -> A3 (FCon x)))
                 -> A3 (x (A2 (FCon x) -> A3 (FCon x)))
-      NB: ‘A2’ is a non-injective type family
+      NB: ‘A3’ is a non-injective type family
     • In the first argument of ‘foldDoC’, namely ‘op’
       In the expression: foldDoC op
       In an equation for ‘fCon’: fCon = foldDoC op
diff --git a/testsuite/tests/indexed-types/should_fail/T4272.stderr b/testsuite/tests/indexed-types/should_fail/T4272.stderr
index 69df514c0f1fa284e2e905f36e444c25ede86f3b..c921445d2e615ad6097036f7f47e079cbcb16a97 100644
--- a/testsuite/tests/indexed-types/should_fail/T4272.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T4272.stderr
@@ -1,17 +1,16 @@
 
-T4272.hs:15:26: error:
-    • Couldn't match type ‘a’ with ‘TermFamily a a’
-      Expected: TermFamily a (TermFamily a a)
-        Actual: TermFamily a a
+T4272.hs:15:19: error:
+    • Couldn't match expected type ‘TermFamily a a’
+                  with actual type ‘a’
       ‘a’ is a rigid type variable bound by
         the type signature for:
           laws :: forall a b. TermLike a => TermFamily a a -> b
         at T4272.hs:14:1-53
-    • In the first argument of ‘terms’, namely
-        ‘(undefined :: TermFamily a a)’
-      In the second argument of ‘prune’, namely
+    • In the second argument of ‘prune’, namely
         ‘(terms (undefined :: TermFamily a a))’
       In the expression: prune t (terms (undefined :: TermFamily a a))
+      In an equation for ‘laws’:
+          laws t = prune t (terms (undefined :: TermFamily a a))
     • Relevant bindings include
         t :: TermFamily a a (bound at T4272.hs:15:6)
         laws :: TermFamily a a -> b (bound at T4272.hs:15:1)
diff --git a/testsuite/tests/indexed-types/should_fail/T5934.stderr b/testsuite/tests/indexed-types/should_fail/T5934.stderr
index 48f8bacef5e887b6829e43a1960659e25b78fcf8..9024f516b87b81e63a34df04ada9dd9a288e9ab5 100644
--- a/testsuite/tests/indexed-types/should_fail/T5934.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T5934.stderr
@@ -1,8 +1,11 @@
 
 T5934.hs:12:7: error:
-    • Couldn't match expected type ‘(forall s. GenST s) -> Int’
-                  with actual type ‘a0’
+    • Couldn't match type ‘a0’
+                     with ‘(forall s. Gen (PrimState (ST s))) -> Int’
+      Expected: (forall s. GenST s) -> Int
+        Actual: a0
       Cannot instantiate unification variable ‘a0’
-      with a type involving polytypes: (forall s. GenST s) -> Int
+      with a type involving polytypes:
+        (forall s. Gen (PrimState (ST s))) -> Int
     • In the expression: 0
       In an equation for ‘run’: run = 0
diff --git a/testsuite/tests/indexed-types/should_fail/T7788.stderr b/testsuite/tests/indexed-types/should_fail/T7788.stderr
index e591fa9b63ea8e9c5209163b35a540000ead05db..65c78aea3b6a558cb7a52b44c73e64613439f41a 100644
--- a/testsuite/tests/indexed-types/should_fail/T7788.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T7788.stderr
@@ -1,7 +1,7 @@
 
 T7788.hs:9:7: error:
     • Reduction stack overflow; size = 201
-      When simplifying the following type: F (Fix Id)
+      When simplifying the following type: F (Id (Fix Id))
       Use -freduction-depth=0 to disable this check
       (any upper bound you could choose might fail unpredictably with
        minor updates to GHC, so disabling the check is recommended if
diff --git a/testsuite/tests/indexed-types/should_fail/T8227.stderr b/testsuite/tests/indexed-types/should_fail/T8227.stderr
index 99d17631637bf3817dfc53348c0ad725fb0bed23..0c8cef576d072654ed0ed71df56f23ab0f15ada0 100644
--- a/testsuite/tests/indexed-types/should_fail/T8227.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T8227.stderr
@@ -1,10 +1,8 @@
 
 T8227.hs:17:27: error:
-    • Couldn't match type: Scalar (V a)
-                     with: Scalar (V a) -> Scalar (V a)
-      Expected: Scalar (V a)
-        Actual: Scalar (V (Scalar (V a) -> Scalar (V a)))
-                -> Scalar (V (Scalar (V a) -> Scalar (V a)))
+    • Couldn't match expected type: Scalar (V a)
+                  with actual type: Scalar (V (Scalar (V a)))
+                                    -> Scalar (V (Scalar (V a)))
     • In the expression: arcLengthToParam eps eps
       In an equation for ‘absoluteToParam’:
           absoluteToParam eps seg = arcLengthToParam eps eps
@@ -13,3 +11,17 @@ T8227.hs:17:27: error:
         eps :: Scalar (V a) (bound at T8227.hs:17:17)
         absoluteToParam :: Scalar (V a) -> a -> Scalar (V a)
           (bound at T8227.hs:17:1)
+
+T8227.hs:17:44: error:
+    • Couldn't match expected type: Scalar (V (Scalar (V a)))
+                  with actual type: Scalar (V a)
+      NB: ‘Scalar’ is a non-injective type family
+    • In the first argument of ‘arcLengthToParam’, namely ‘eps’
+      In the expression: arcLengthToParam eps eps
+      In an equation for ‘absoluteToParam’:
+          absoluteToParam eps seg = arcLengthToParam eps eps
+    • Relevant bindings include
+        seg :: a (bound at T8227.hs:17:21)
+        eps :: Scalar (V a) (bound at T8227.hs:17:17)
+        absoluteToParam :: Scalar (V a) -> a -> Scalar (V a)
+          (bound at T8227.hs:17:1)
diff --git a/testsuite/tests/indexed-types/should_fail/T8518.stderr b/testsuite/tests/indexed-types/should_fail/T8518.stderr
index 1f244f9ee21ec218fadc0ce209e62000529048ef..89ba8308a1261ad86ff32c709e68f3a311d451a3 100644
--- a/testsuite/tests/indexed-types/should_fail/T8518.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T8518.stderr
@@ -1,10 +1,9 @@
 
 T8518.hs:14:18: error:
-    • Couldn't match expected type: Z c -> B c -> Maybe (F c)
-                  with actual type: F c
-    • The function ‘rpt’ is applied to four value arguments,
-        but its type ‘Int -> c -> F c’ has only two
-      In the expression: rpt (4 :: Int) c z b
+    • Couldn't match type: F c
+                     with: Z c -> B c -> F c
+        arising from a use of ‘rpt’
+    • In the expression: rpt (4 :: Int) c z b
       In an equation for ‘callCont’:
           callCont c z b
             = rpt (4 :: Int) c z b
@@ -16,17 +15,3 @@ T8518.hs:14:18: error:
         z :: Z c (bound at T8518.hs:14:12)
         c :: c (bound at T8518.hs:14:10)
         callCont :: c -> Z c -> B c -> Maybe (F c) (bound at T8518.hs:14:1)
-
-T8518.hs:16:9: error:
-    • Couldn't match type: F t1
-                     with: Z t1 -> B t1 -> F t1
-      Expected: t -> t1 -> F t1
-        Actual: t -> t1 -> Z t1 -> B t1 -> F t1
-    • In an equation for ‘callCont’:
-          callCont c z b
-            = rpt (4 :: Int) c z b
-            where
-                rpt 0 c' z' b' = fromJust (fst <$> (continue c' z' b'))
-                rpt i c' z' b' = let ... in rpt (i - 1) c''
-    • Relevant bindings include
-        rpt :: t -> t1 -> F t1 (bound at T8518.hs:16:9)
diff --git a/testsuite/tests/indexed-types/should_fail/T9554.stderr b/testsuite/tests/indexed-types/should_fail/T9554.stderr
index 2bd5c2ab75c45d6359cb9bbbe132584f6967aac9..b62badda9d7c63c187331bbee4e15f3a1fa77f38 100644
--- a/testsuite/tests/indexed-types/should_fail/T9554.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T9554.stderr
@@ -2,7 +2,7 @@
 T9554.hs:11:9: error:
     • Reduction stack overflow; size = 201
       When simplifying the following type:
-        F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F Bool))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
+        F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F Bool)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
       Use -freduction-depth=0 to disable this check
       (any upper bound you could choose might fail unpredictably with
        minor updates to GHC, so disabling the check is recommended if
@@ -13,7 +13,7 @@ T9554.hs:11:9: error:
 T9554.hs:13:17: error:
     • Reduction stack overflow; size = 201
       When simplifying the following type:
-        F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F Bool))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
+        F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F (F Bool)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
       Use -freduction-depth=0 to disable this check
       (any upper bound you could choose might fail unpredictably with
        minor updates to GHC, so disabling the check is recommended if
diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T
index 428ab8d4f1ecc09709c7b66e960b7877df7168b9..9d2c68f095fde1a176bb39f68b50617ca3217952 100644
--- a/testsuite/tests/indexed-types/should_fail/all.T
+++ b/testsuite/tests/indexed-types/should_fail/all.T
@@ -163,3 +163,4 @@ test('T17008a', normal, compile_fail, ['-fprint-explicit-kinds'])
 test('T13571', normal, compile_fail, [''])
 test('T13571a', normal, compile_fail, [''])
 test('T18648', normal, compile_fail, [''])
+test('ExpandTFs', normal, compile_fail, [''])
diff --git a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr
index ea48244e0c8caf0d9a750f9be392c7060afffa90..7a0ad230f426f9d20e5efa13e3a54d3b14280373 100644
--- a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr
@@ -65,7 +65,7 @@ SplicesUsed.hs:16:2: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • In the type signature: foo :: _ => _
 
 SplicesUsed.hs:16:2: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Eq a’
+    • Found extra-constraints wildcard standing for ‘Eq a’
       Where: ‘a’ is a rigid type variable bound by
                the inferred type of foo :: Eq a => a -> a -> Bool
                at SplicesUsed.hs:16:2-11
diff --git a/testsuite/tests/partial-sigs/should_compile/SuperCls.stderr b/testsuite/tests/partial-sigs/should_compile/SuperCls.stderr
index a11164482c4127053ed0e1e1213ef121537aa8ef..0f1a1fa77b1d4659a4a3f305a098e13b4d516bb8 100644
--- a/testsuite/tests/partial-sigs/should_compile/SuperCls.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/SuperCls.stderr
@@ -1,4 +1,4 @@
 
 SuperCls.hs:4:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘()’
+    • Found extra-constraints wildcard standing for ‘()’
     • In the type signature: f :: (Ord a, _) => a -> Bool
diff --git a/testsuite/tests/partial-sigs/should_compile/T10403.stderr b/testsuite/tests/partial-sigs/should_compile/T10403.stderr
index a3cdc763fc31943c264a898dae1900c3017ea461..1a7162d61254f856563b7c080f6e0a2dc7d54d39 100644
--- a/testsuite/tests/partial-sigs/should_compile/T10403.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T10403.stderr
@@ -1,6 +1,6 @@
 
 T10403.hs:15:7: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Functor f’
+    • Found extra-constraints wildcard standing for ‘Functor f’
       Where: ‘f’ is a rigid type variable bound by
                the inferred type of h1 :: Functor f => (a -> a1) -> f a -> H f
                at T10403.hs:17:1-41
diff --git a/testsuite/tests/partial-sigs/should_compile/T10519.stderr b/testsuite/tests/partial-sigs/should_compile/T10519.stderr
index 13f1104da73bee0cbb93d3824583998dbb19360e..d2db5da38e70f2a149b5cd526c14830cef40d5e1 100644
--- a/testsuite/tests/partial-sigs/should_compile/T10519.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T10519.stderr
@@ -1,6 +1,6 @@
 
 T10519.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Eq a’
+    • Found extra-constraints wildcard standing for ‘Eq a’
       Where: ‘a’ is a rigid type variable bound by
                the inferred type of foo :: Eq a => a -> a -> Bool
                at T10519.hs:5:15
diff --git a/testsuite/tests/partial-sigs/should_compile/T11016.stderr b/testsuite/tests/partial-sigs/should_compile/T11016.stderr
index 49363fb24c3f13cedb5b60494563bcdff09b86ba..8d3ffe4cf54a43fbfa8bcf69c88b8d43340dbc31 100644
--- a/testsuite/tests/partial-sigs/should_compile/T11016.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T11016.stderr
@@ -1,6 +1,6 @@
 
 T11016.hs:5:19: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘()’
+    • Found extra-constraints wildcard standing for ‘()’
     • In the type signature: f1 :: (?x :: Int, _) => Int
 
 T11016.hs:8:22: warning: [-Wpartial-type-signatures (in -Wdefault)]
diff --git a/testsuite/tests/partial-sigs/should_compile/T11670.stderr b/testsuite/tests/partial-sigs/should_compile/T11670.stderr
index 87e36e5fc5dc310bfd4692e20ad166d911b6a657..2d2672237399772d7ca0b6d307562fb3f8d1f87b 100644
--- a/testsuite/tests/partial-sigs/should_compile/T11670.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T11670.stderr
@@ -9,7 +9,7 @@ T11670.hs:10:42: warning: [-Wpartial-type-signatures (in -Wdefault)]
         peek :: Ptr a -> IO CLong (bound at T11670.hs:10:1)
 
 T11670.hs:13:40: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Storable w’
+    • Found extra-constraints wildcard standing for ‘Storable w’
       Where: ‘w’ is a rigid type variable bound by
                the inferred type of <expression> :: Storable w => IO w
                at T11670.hs:13:40-48
diff --git a/testsuite/tests/partial-sigs/should_compile/T12844.stderr b/testsuite/tests/partial-sigs/should_compile/T12844.stderr
index 3d8031143c2cb428b83863a6d9f0cbcc2d4b90d8..331570aa93945eccf7923512f3780d2bd34c87cb 100644
--- a/testsuite/tests/partial-sigs/should_compile/T12844.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T12844.stderr
@@ -1,10 +1,10 @@
 
 T12844.hs:12:9: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’
-        standing for ‘(Foo rngs, Head rngs ~ '(r, r'))’
-      Where: ‘rngs’, ‘k’, ‘r’, ‘k1’, ‘r'’
+    • Found extra-constraints wildcard standing for
+        ‘(Head rngs ~ '(r, r'), Foo rngs)’
+      Where: ‘r’, ‘r'’, ‘k’, ‘k1’, ‘rngs’
                are rigid type variables bound by
                the inferred type of
-                 bar :: (Foo rngs, Head rngs ~ '(r, r')) => FooData rngs
+                 bar :: (Head rngs ~ '(r, r'), Foo rngs) => FooData rngs
                at T12844.hs:(12,1)-(13,9)
     • In the type signature: bar :: _ => FooData rngs
diff --git a/testsuite/tests/partial-sigs/should_compile/T12845.stderr b/testsuite/tests/partial-sigs/should_compile/T12845.stderr
index 0ca72ce5e327215cbe24a4e76dabb1d4cf172c8d..fb7cc70db41d78f294d02ed907626707642c6035 100644
--- a/testsuite/tests/partial-sigs/should_compile/T12845.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T12845.stderr
@@ -1,6 +1,6 @@
 
 T12845.hs:18:70: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘()’
+    • Found extra-constraints wildcard standing for ‘()’
     • In the type signature:
         broken :: forall r r' rngs.
                   ('(r, r') ~ Head rngs, Bar r r' ~ 'True, _) =>
diff --git a/testsuite/tests/partial-sigs/should_compile/T13482.stderr b/testsuite/tests/partial-sigs/should_compile/T13482.stderr
index dc2b156703c8021bd4537a63677f94c368887cf0..85cd1115dc1232f675c9283e8dad58b5f5771011 100644
--- a/testsuite/tests/partial-sigs/should_compile/T13482.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T13482.stderr
@@ -1,6 +1,6 @@
 
 T13482.hs:10:32: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘(Eq m, Monoid m)’
+    • Found extra-constraints wildcard standing for ‘(Eq m, Monoid m)’
       Where: ‘m’ is a rigid type variable bound by
                the inferred type of
                  minimal1_noksig :: (Eq m, Monoid m) => Int -> Bool
@@ -9,21 +9,21 @@ T13482.hs:10:32: warning: [-Wpartial-type-signatures (in -Wdefault)]
         minimal1_noksig :: forall m. _ => Int -> Bool
 
 T13482.hs:13:33: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘(Eq m, Monoid m)’
+    • Found extra-constraints wildcard standing for ‘(Eq m, Monoid m)’
       Where: ‘m’ is a rigid type variable bound by
                the inferred type of minimal1 :: (Eq m, Monoid m) => Bool
                at T13482.hs:13:21
     • In the type signature: minimal1 :: forall (m :: Type). _ => Bool
 
 T13482.hs:16:30: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Monoid m’
+    • Found extra-constraints wildcard standing for ‘Monoid m’
       Where: ‘m’ is a rigid type variable bound by
                the inferred type of minimal2 :: (Eq m, Monoid m) => Bool
                at T13482.hs:16:20
     • In the type signature: minimal2 :: forall m. (Eq m, _) => Bool
 
 T13482.hs:19:34: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Eq m’
+    • Found extra-constraints wildcard standing for ‘Eq m’
       Where: ‘m’ is a rigid type variable bound by
                the inferred type of minimal3 :: (Monoid m, Eq m) => Bool
                at T13482.hs:19:20
diff --git a/testsuite/tests/partial-sigs/should_compile/T14217.stderr b/testsuite/tests/partial-sigs/should_compile/T14217.stderr
index 97f7854cdf4a7e48f1311f7a5901119940832396..913753be98b859e72d6d988ec43b5ce65ef9c652 100644
--- a/testsuite/tests/partial-sigs/should_compile/T14217.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T14217.stderr
@@ -1,14 +1,14 @@
 
 T14217.hs:32:11: error:
-    • Found type wildcard ‘_’
-        standing for ‘(Eq a1, Eq a2, Eq a3, Eq a4, Eq a5, Eq a6, Eq a7,
-                       Eq a8, Eq a9, Eq a10, Eq a11, Eq a12, Eq a13, Eq a14, Eq a15,
-                       Eq a16, Eq a17, Eq a18, Eq a19, Eq a20, Eq a21, Eq a22, Eq a23,
-                       Eq a24, Eq a25, Eq a26, Eq a27, Eq a28, Eq a29, Eq a30, Eq a31,
-                       Eq a32, Eq a33, Eq a34, Eq a35, Eq a36, Eq a37, Eq a38, Eq a39,
-                       Eq a40, Eq a41, Eq a42, Eq a43, Eq a44, Eq a45, Eq a46, Eq a47,
-                       Eq a48, Eq a49, Eq a50, Eq a51, Eq a52, Eq a53, Eq a54, Eq a55,
-                       Eq a56, Eq a57, Eq a58, Eq a59, Eq a60, Eq a61, Eq a62, Eq a63)’
+    • Found extra-constraints wildcard standing for
+        ‘(Eq a1, Eq a2, Eq a3, Eq a4, Eq a5, Eq a6, Eq a7, Eq a8, Eq a9,
+          Eq a10, Eq a11, Eq a12, Eq a13, Eq a14, Eq a15, Eq a16, Eq a17,
+          Eq a18, Eq a19, Eq a20, Eq a21, Eq a22, Eq a23, Eq a24, Eq a25,
+          Eq a26, Eq a27, Eq a28, Eq a29, Eq a30, Eq a31, Eq a32, Eq a33,
+          Eq a34, Eq a35, Eq a36, Eq a37, Eq a38, Eq a39, Eq a40, Eq a41,
+          Eq a42, Eq a43, Eq a44, Eq a45, Eq a46, Eq a47, Eq a48, Eq a49,
+          Eq a50, Eq a51, Eq a52, Eq a53, Eq a54, Eq a55, Eq a56, Eq a57,
+          Eq a58, Eq a59, Eq a60, Eq a61, Eq a62, Eq a63)’
       Where: ‘a1’, ‘a2’, ‘a3’, ‘a4’, ‘a5’, ‘a6’, ‘a7’, ‘a8’, ‘a9’, ‘a10’,
              ‘a11’, ‘a12’, ‘a13’, ‘a14’, ‘a15’, ‘a16’, ‘a17’, ‘a18’, ‘a19’,
              ‘a20’, ‘a21’, ‘a22’, ‘a23’, ‘a24’, ‘a25’, ‘a26’, ‘a27’, ‘a28’,
diff --git a/testsuite/tests/partial-sigs/should_compile/T14643.stderr b/testsuite/tests/partial-sigs/should_compile/T14643.stderr
index 60288670fb481a6e67d31c7b0bda3cd393248c46..e2dd144bd319b79ec5197c71c4600500ff5a9f87 100644
--- a/testsuite/tests/partial-sigs/should_compile/T14643.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T14643.stderr
@@ -1,8 +1,8 @@
 
 T14643.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘()’
+    • Found extra-constraints wildcard standing for ‘()’
     • In the type signature: ag :: (Num a, _) => a -> a
 
 T14643.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘()’
+    • Found extra-constraints wildcard standing for ‘()’
     • In the type signature: af :: (Num a, _) => a -> a
diff --git a/testsuite/tests/partial-sigs/should_compile/T14643a.stderr b/testsuite/tests/partial-sigs/should_compile/T14643a.stderr
index 1514ac92ed1213a658c2d935100a5f800ae207db..6f4147247266587e0556c3dd68de1091a6ab0234 100644
--- a/testsuite/tests/partial-sigs/should_compile/T14643a.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T14643a.stderr
@@ -1,8 +1,8 @@
 
 T14643a.hs:5:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘()’
+    • Found extra-constraints wildcard standing for ‘()’
     • In the type signature: af :: (Num a, _) => a -> a
 
 T14643a.hs:8:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘()’
+    • Found extra-constraints wildcard standing for ‘()’
     • In the type signature: ag :: (Num a, _) => a -> a
diff --git a/testsuite/tests/partial-sigs/should_compile/T14715.stderr b/testsuite/tests/partial-sigs/should_compile/T14715.stderr
index 901ece018fefa158759c6172bbdf62e42e53614b..e352f0d644589c992918d1c99dd77f1f5dce36e7 100644
--- a/testsuite/tests/partial-sigs/should_compile/T14715.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T14715.stderr
@@ -1,6 +1,7 @@
 
 T14715.hs:13:53: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Reduce (LiftOf zq) zq’
+    • Found extra-constraints wildcard standing for
+        ‘Reduce (LiftOf zq) zq’
       Where: ‘zq’ is a rigid type variable bound by
                the inferred type of
                  bench_mulPublic :: (z ~ LiftOf zq, Reduce (LiftOf zq) zq) =>
diff --git a/testsuite/tests/partial-sigs/should_compile/T15039a.stderr b/testsuite/tests/partial-sigs/should_compile/T15039a.stderr
index e52d911caca3b24d00aa06305d74ce0b56797952..1f07a650aced193dec2fe5d14e2a10b9421160cb 100644
--- a/testsuite/tests/partial-sigs/should_compile/T15039a.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T15039a.stderr
@@ -48,7 +48,7 @@ T15039a.hs:33:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
         ex6 :: Dict (Coercible a b) -> () (bound at T15039a.hs:33:1)
 
 T15039a.hs:35:8: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Coercible a b’
+    • Found extra-constraints wildcard standing for ‘Coercible a b’
       Where: ‘a’, ‘b’ are rigid type variables bound by
                the inferred type of ex7 :: Coercible a b => Coercion a b
                at T15039a.hs:35:1-44
diff --git a/testsuite/tests/partial-sigs/should_compile/T15039b.stderr b/testsuite/tests/partial-sigs/should_compile/T15039b.stderr
index da14f26a1700a63919cb19249e1757253bf66508..73d366eb655b14f3a9c61c581b0d5cfd320cc94b 100644
--- a/testsuite/tests/partial-sigs/should_compile/T15039b.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T15039b.stderr
@@ -49,7 +49,8 @@ T15039b.hs:33:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
         ex6 :: Dict (Coercible @(*) a b) -> () (bound at T15039b.hs:33:1)
 
 T15039b.hs:35:8: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Coercible @(*) a b’
+    • Found extra-constraints wildcard standing for
+        ‘Coercible @(*) a b’
       Where: ‘a’, ‘b’ are rigid type variables bound by
                the inferred type of ex7 :: Coercible @(*) a b => Coercion @{*} a b
                at T15039b.hs:35:1-44
diff --git a/testsuite/tests/partial-sigs/should_compile/T15039c.stderr b/testsuite/tests/partial-sigs/should_compile/T15039c.stderr
index c7ad5e861b847311ae9d7fb6fd9e8517b79c76a1..658c30c2b7f318b5fef70b9c69a0ed8cb91b46c2 100644
--- a/testsuite/tests/partial-sigs/should_compile/T15039c.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T15039c.stderr
@@ -48,7 +48,7 @@ T15039c.hs:33:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
         ex6 :: Dict (Coercible a b) -> () (bound at T15039c.hs:33:1)
 
 T15039c.hs:35:8: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Coercible a b’
+    • Found extra-constraints wildcard standing for ‘Coercible a b’
       Where: ‘a’, ‘b’ are rigid type variables bound by
                the inferred type of ex7 :: Coercible a b => Coercion a b
                at T15039c.hs:35:1-44
diff --git a/testsuite/tests/partial-sigs/should_compile/T15039d.stderr b/testsuite/tests/partial-sigs/should_compile/T15039d.stderr
index 68882c391f6750fc0e80f8773687dea7776b954d..587b64126a2b9d3119a4f16240705cf453dcbd8b 100644
--- a/testsuite/tests/partial-sigs/should_compile/T15039d.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/T15039d.stderr
@@ -50,7 +50,8 @@ T15039d.hs:33:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
         ex6 :: Dict (Coercible @(*) a b) -> () (bound at T15039d.hs:33:1)
 
 T15039d.hs:35:8: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Coercible @(*) a b’
+    • Found extra-constraints wildcard standing for
+        ‘Coercible @(*) a b’
       Where: ‘a’, ‘b’ are rigid type variables bound by
                the inferred type of ex7 :: Coercible @(*) a b => Coercion @{*} a b
                at T15039d.hs:35:1-44
diff --git a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr
index 5dc9b0797e514062c73d830062aa6d1961607660..e9f875b6a38cc0fa742b41ecdaeeb65746981da4 100644
--- a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr
@@ -2,7 +2,7 @@ TYPE SIGNATURES
   bar :: forall {t} {w}. t -> (t -> w) -> w
   foo :: forall {a}. (Show a, Enum a) => a -> String
 Dependent modules: []
-Dependent packages: [base-4.14.0.0, ghc-bignum-1.0, ghc-prim-0.7.0]
+Dependent packages: [base-4.15.0.0, ghc-bignum-1.0, ghc-prim-0.7.0]
 
 WarningWildcardInstantiations.hs:5:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_a’ standing for ‘a’
@@ -12,7 +12,7 @@ WarningWildcardInstantiations.hs:5:14: warning: [-Wpartial-type-signatures (in -
     • In the type signature: foo :: (Show _a, _) => _a -> _
 
 WarningWildcardInstantiations.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Enum a’
+    • Found extra-constraints wildcard standing for ‘Enum a’
       Where: ‘a’ is a rigid type variable bound by
                the inferred type of foo :: (Show a, Enum a) => a -> String
                at WarningWildcardInstantiations.hs:6:1-21
diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr
index 6978418c46a13171d5a3280b2d749e983aeaed7a..823b1f9e5e7e909a3121a8176ab92abf71ef7bc6 100644
--- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr
+++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr
@@ -1,6 +1,6 @@
 
 ExtraConstraintsWildcardInExpressionSignature.hs:5:20: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘Eq a1’
+    • Found extra-constraints wildcard standing for ‘Eq a1’
       Where: ‘a1’ is a rigid type variable bound by
                the inferred type of <expression> :: Eq a1 => a1 -> a1 -> Bool
                at ExtraConstraintsWildcardInExpressionSignature.hs:5:20-25
diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr
index 3fc90ec240304e3a0c59c297c56779850e8dd5bb..496e1a73935b2ee156f7f4edf4542d6088171d7b 100644
--- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr
+++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr
@@ -1,6 +1,6 @@
 
 ExtraConstraintsWildcardNotEnabled.hs:4:10: error:
-    • Found type wildcard ‘_’ standing for ‘Show a’
+    • Found extra-constraints wildcard standing for ‘Show a’
       Where: ‘a’ is a rigid type variable bound by
                the inferred type of show' :: Show a => a -> String
                at ExtraConstraintsWildcardNotEnabled.hs:4:1-25
diff --git a/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr b/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr
index 83663188fc48201a972d50847b8f6557697ac14e..9e9505d7f0243ae474e1cf09c14516f464c1b831 100644
--- a/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr
+++ b/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr
@@ -8,7 +8,7 @@ InstantiatedNamedWildcardsInConstraints.hs:4:14: error:
     • In the type signature: foo :: (Enum _a, _) => _a -> (String, b)
 
 InstantiatedNamedWildcardsInConstraints.hs:4:18: error:
-    • Found type wildcard ‘_’ standing for ‘Show b’
+    • Found extra-constraints wildcard standing for ‘Show b’
       Where: ‘b’ is a rigid type variable bound by
                the inferred type of foo :: (Enum b, Show b) => b -> (String, b)
                at InstantiatedNamedWildcardsInConstraints.hs:4:1-40
diff --git a/testsuite/tests/partial-sigs/should_fail/T10999.stderr b/testsuite/tests/partial-sigs/should_fail/T10999.stderr
index b0697fe60bf52e06085bf928ef54f3fd0eb02b6a..356b068031dca7b8a083bcdac6d0abc28bdc9b8d 100644
--- a/testsuite/tests/partial-sigs/should_fail/T10999.stderr
+++ b/testsuite/tests/partial-sigs/should_fail/T10999.stderr
@@ -1,6 +1,6 @@
 
 T10999.hs:5:6: error:
-    • Found type wildcard ‘_’ standing for ‘Ord a’
+    • Found extra-constraints wildcard standing for ‘Ord a’
       Where: ‘a’ is a rigid type variable bound by
                the inferred type of f :: Ord a => () -> Set.Set a
                at T10999.hs:6:1-28
diff --git a/testsuite/tests/partial-sigs/should_fail/T11515.stderr b/testsuite/tests/partial-sigs/should_fail/T11515.stderr
index 2870457500c797c3e1b277429ede2245a4181c3c..df8da03208227b07eadd4890129fe37901dd67a6 100644
--- a/testsuite/tests/partial-sigs/should_fail/T11515.stderr
+++ b/testsuite/tests/partial-sigs/should_fail/T11515.stderr
@@ -1,5 +1,5 @@
 
 T11515.hs:7:20: error:
-    • Found type wildcard ‘_’ standing for ‘()’
+    • Found extra-constraints wildcard standing for ‘()’
       To use the inferred type, enable PartialTypeSignatures
     • In the type signature: foo :: (ShowSyn a, _) => a -> String
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr
index a7e31fd8c94ec35c8b8eebf9b97b491ed347edd9..827356a7aeb563c7f4fef21955e719ef5d8d9d36 100644
--- a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr
+++ b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr
@@ -8,7 +8,7 @@ WildcardInstantiations.hs:5:14: error:
     • In the type signature: foo :: (Show _a, _) => _a -> _
 
 WildcardInstantiations.hs:5:18: error:
-    • Found type wildcard ‘_’ standing for ‘Enum a’
+    • Found extra-constraints wildcard standing for ‘Enum a’
       Where: ‘a’ is a rigid type variable bound by
                the inferred type of foo :: (Show a, Enum a) => a -> String
                at WildcardInstantiations.hs:6:1-21
diff --git a/testsuite/tests/polykinds/T14172.stderr b/testsuite/tests/polykinds/T14172.stderr
index 0f5d0271b4bba950177b97ba9bd58ed8318b1e72..3496b04538a9b37358fc86b8ba76665101118f97 100644
--- a/testsuite/tests/polykinds/T14172.stderr
+++ b/testsuite/tests/polykinds/T14172.stderr
@@ -11,11 +11,9 @@ T14172.hs:6:46: error:
       In the type ‘(a -> f b) -> g a -> f (h _)’
 
 T14172.hs:7:19: error:
-    • Couldn't match type ‘a’ with ‘g'0 a’
-      Expected: (f'0 a -> f (f'0 b)) -> Compose f'0 g'0 a -> f (h a')
-        Actual: (Unwrapped (Compose f'0 g'0 a) -> f (Unwrapped (h a')))
-                -> Compose f'0 g'0 a -> f (h a')
-      ‘a’ is a rigid type variable bound by
+    • Couldn't match type ‘h’ with ‘Compose f'0 g'0’
+        arising from a use of ‘_Wrapping’
+      ‘h’ is a rigid type variable bound by
         the inferred type of
           traverseCompose :: (a -> f b) -> g a -> f (h a')
         at T14172.hs:6:1-47
diff --git a/testsuite/tests/roles/should_compile/Roles3.stderr b/testsuite/tests/roles/should_compile/Roles3.stderr
index bfc62cc19633bd8d1ce9d60cf4be3a7072a533ea..c3bfb99faa1fe1b4cfcb727163ef14f622d3020f 100644
--- a/testsuite/tests/roles/should_compile/Roles3.stderr
+++ b/testsuite/tests/roles/should_compile/Roles3.stderr
@@ -21,7 +21,7 @@ COERCION AXIOMS
   axiom Roles3.N:C3 :: C3 a b = a -> F3 b -> F3 b
   axiom Roles3.N:C4 :: C4 a b = a -> F4 b -> F4 b
 Dependent modules: []
-Dependent packages: [base-4.15.0.0, ghc-bignum-1.0, ghc-prim-0.7.0]
+Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.7.0]
 
 ==================== Typechecker ====================
 Roles3.$tcC4
@@ -53,12 +53,12 @@ $krep [InlPrag=[~]] = GHC.Types.KindRepVar 1
 $krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
 $krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
 $krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
-$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
-$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
 $krep [InlPrag=[~]] = GHC.Types.KindRepFun GHC.Types.krep$* $krep
 $krep [InlPrag=[~]] = GHC.Types.KindRepFun GHC.Types.krep$* $krep
+$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
 $krep [InlPrag=[~]]
   = GHC.Types.KindRepTyConApp GHC.Types.$tcConstraint []
+$krep [InlPrag=[~]] = GHC.Types.KindRepFun $krep $krep
 $krep [InlPrag=[~]]
   = GHC.Types.KindRepTyConApp
       GHC.Types.$tc~ ((:) GHC.Types.krep$* ((:) $krep ((:) $krep [])))
diff --git a/testsuite/tests/typecheck/should_compile/CbvOverlap.hs b/testsuite/tests/typecheck/should_compile/CbvOverlap.hs
new file mode 100644
index 0000000000000000000000000000000000000000..4e3b40f16138cc9f167c50326f32358037fdb89a
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/CbvOverlap.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts #-}
+
+module CbvOverlap where
+
+-- This is concerned with Note [Type variable cycles in Givens] and class lookup
+
+class C a where
+  meth :: a -> ()
+
+instance C Int where
+  meth _ = ()
+
+type family F a
+
+foo :: C (F a) => a -> Int -> ()
+foo _ n = meth n
diff --git a/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap.hs b/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap.hs
new file mode 100644
index 0000000000000000000000000000000000000000..765379a2032a8c85ae63715a44e73759ae59c690
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses,
+             TypeFamilies, FlexibleContexts, AllowAmbiguousTypes #-}
+
+module InstanceGivenOverlap where
+
+-- See Note [Instance and Given overlap] in GHC.Tc.Solver.Interact.
+-- This tests the Note when the Wanted contains a type family.
+
+class P a
+class Q a
+class R a b
+
+instance P x => Q [x]
+instance (x ~ y) => R y [x]
+
+type family F a b where
+  F [a] a = a
+
+wob :: forall a b. (Q [F a b], R b a) => a -> Int
+wob = undefined
+
+g :: forall a. Q [a] => [a] -> Int
+g x = wob x
diff --git a/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap2.hs b/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap2.hs
new file mode 100644
index 0000000000000000000000000000000000000000..67c475ee2382495b2ff0f498a6468c3f7ee600fc
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InstanceGivenOverlap2.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE ScopedTypeVariables, AllowAmbiguousTypes, TypeApplications,
+             TypeFamilies, PolyKinds, DataKinds, FlexibleInstances,
+             MultiParamTypeClasses, FlexibleContexts, PartialTypeSignatures #-}
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
+
+module InstanceGivenOverlap2 where
+
+import Data.Proxy
+
+class P a
+class Q a
+class R a b
+
+newtype Tagged (t :: k) a = Tagged a
+
+type family F a
+type instance F (Tagged @Bool t a) = [a]
+
+instance P x => Q [x]
+instance (x ~ y) => R y [x]
+
+wob :: forall a b. (Q [b], R b a) => a -> Int
+wob = undefined
+
+it'sABoolNow :: forall (t :: Bool). Int
+it'sABoolNow = undefined
+
+class HasBoolKind t
+instance k ~ Bool => HasBoolKind (t :: k)
+
+it'sABoolLater :: forall t. HasBoolKind t => Int
+it'sABoolLater = undefined
+
+g :: forall t a. Q (F (Tagged t a)) => Proxy t -> [a] -> _
+g _ x = it'sABoolNow @t + wob x
+
+g2 :: forall t a. Q (F (Tagged t a)) => Proxy t -> [a] -> _
+g2 _ x = wob x + it'sABoolNow @t
+
+g3 :: forall t a. Q (F (Tagged t a)) => Proxy t -> [a] -> _
+g3 _ x = it'sABoolLater @t + wob x
+
+g4 :: forall t a. Q (F (Tagged t a)) => Proxy t -> [a] -> _
+g4 _ x = wob x + it'sABoolLater @t
diff --git a/testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs b/testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f1280205b2a952559ab224398dd4343b19401bfb
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/LocalGivenEqs.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE RankNTypes, TypeFamilies, FlexibleInstances #-}
+{-# OPTIONS_GHC -Wno-missing-methods -Wno-unused-matches #-}
+
+module LocalGivenEqs where
+
+-- See Note [When does an implication have given equalities?] in GHC.Tc.Solver.Monad;
+-- this tests custom treatment for LocalGivenEqs
+
+{-
+I (Richard E) tried somewhat half-heartedly to minimize this, but failed.
+The key bit is the use of the ECP constructor inside the lambda in happyReduction_508.
+(The lack of a type signature on that is not at issue, I believe.) The type
+of ECP is
+  (forall b. DisambECP b => PV (Located b)) -> ECP
+So, the argument to ECP gets a [G] DisambECP b, which (via its superclass) grants
+us [G] b ~ (Body b) GhcPs. In order to infer the type of happy_var_2, we need to
+float some wanted out past this equality. We have Note [Let-bound skolems]
+in GHC.Tc.Solver.Monad to consider this Given equality to be let-like, and thus
+not prevent floating. But, note that the equality isn't quite let-like, because
+it mentions b in its RHS. It thus triggers Note [Type variable cycles in Givens]
+in GHC.Tc.Solver.Canonical. That Note says we change the situation to
+  [G] b ~ cbv GhcPs
+  [G] Body b ~ cbv
+for some fresh CycleBreakerTv cbv. Now, our original equality looks to be let-like,
+but the new cbv equality is *not* let-like -- note that the variable is on the RHS.
+The solution is to consider any equality whose free variables are all at the current
+level to not stop equalities from floating. These are called *local*. Because both
+Givens are local in this way, they no longer prevent floating, and we can type-check
+this example.
+-}
+
+import Data.Kind ( Type )
+import GHC.Exts ( Any )
+
+infixr 9 `HappyStk`
+data HappyStk a = HappyStk a (HappyStk a)
+newtype HappyWrap201 = HappyWrap201 (ECP)
+newtype HappyWrap205 = HappyWrap205 (([Located Token],Bool))
+
+newtype HappyAbsSyn  = HappyAbsSyn HappyAny
+type HappyAny = Any
+
+newtype ECP =
+  ECP { unECP :: forall b. DisambECP b => PV (Located b) }
+
+data PV a
+data P a
+data GhcPs
+data Token
+data Located a
+data AnnKeywordId = AnnIf | AnnThen | AnnElse | AnnSemi
+data AddAnn
+data SrcSpan
+type LHsExpr a = Located (HsExpr a)
+data HsExpr a
+
+class b ~ (Body b) GhcPs => DisambECP b where
+  type Body b :: Type -> Type
+  mkHsIfPV :: SrcSpan
+         -> LHsExpr GhcPs
+         -> Bool  -- semicolon?
+         -> Located b
+         -> Bool  -- semicolon?
+         -> Located b
+         -> PV (Located b)
+
+instance DisambECP (HsExpr GhcPs) where
+  type Body (HsExpr GhcPs) = HsExpr
+  mkHsIfPV = undefined
+
+instance Functor P
+instance Applicative P
+instance Monad P
+
+instance Functor PV
+instance Applicative PV
+instance Monad PV
+
+mj :: AnnKeywordId -> Located e -> AddAnn
+mj = undefined
+
+amms :: Monad m => m (Located a) -> [AddAnn] -> m (Located a)
+amms = undefined
+
+happyIn208 :: ECP -> HappyAbsSyn
+happyIn208 = undefined
+
+happyReturn :: () => a -> P a
+happyReturn = (return)
+
+happyThen :: () => P a -> (a -> P b) -> P b
+happyThen = (>>=)
+
+comb2 :: Located a -> Located b -> SrcSpan
+comb2 = undefined
+
+runPV :: PV a -> P a
+runPV = undefined
+
+happyOutTok :: HappyAbsSyn -> Located Token
+happyOutTok = undefined
+
+happyOut201 :: HappyAbsSyn -> HappyWrap201
+happyOut201 = undefined
+
+happyOut205 :: HappyAbsSyn -> HappyWrap205
+happyOut205 = undefined
+
+happyReduction_508 (happy_x_8 `HappyStk`
+        happy_x_7 `HappyStk`
+        happy_x_6 `HappyStk`
+        happy_x_5 `HappyStk`
+        happy_x_4 `HappyStk`
+        happy_x_3 `HappyStk`
+        happy_x_2 `HappyStk`
+        happy_x_1 `HappyStk`
+        happyRest) tk
+         = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 ->
+        case happyOut201 happy_x_2 of { (HappyWrap201 happy_var_2) ->
+        case happyOut205 happy_x_3 of { (HappyWrap205 happy_var_3) ->
+        case happyOutTok happy_x_4 of { happy_var_4 ->
+        case happyOut201 happy_x_5 of { (HappyWrap201 happy_var_5) ->
+        case happyOut205 happy_x_6 of { (HappyWrap205 happy_var_6) ->
+        case happyOutTok happy_x_7 of { happy_var_7 ->
+        case happyOut201 happy_x_8 of { (HappyWrap201 happy_var_8) ->
+                          -- uncomment this next signature to avoid the need
+                          -- for special treatment of floating described above
+        ( runPV (unECP happy_var_2 {- :: PV (LHsExpr GhcPs) -}) >>= \ happy_var_2 ->
+                            return $ ECP $
+                              unECP happy_var_5 >>= \ happy_var_5 ->
+                              unECP happy_var_8 >>= \ happy_var_8 ->
+                              amms (mkHsIfPV (comb2 happy_var_1 happy_var_8) happy_var_2 (snd happy_var_3) happy_var_5 (snd happy_var_6) happy_var_8)
+                                  (mj AnnIf happy_var_1:mj AnnThen happy_var_4
+                                     :mj AnnElse happy_var_7
+                                     :(map (\l -> mj AnnSemi l) (fst happy_var_3))
+                                    ++(map (\l -> mj AnnSemi l) (fst happy_var_6))))}}}}}}}})
+        ) (\r -> happyReturn (happyIn208 r))
diff --git a/testsuite/tests/typecheck/should_compile/LocalGivenEqs2.hs b/testsuite/tests/typecheck/should_compile/LocalGivenEqs2.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f15ab92de75d70f979366eb345aa4470b71007c7
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/LocalGivenEqs2.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE TypeFamilies, GADTSyntax, ExistentialQuantification #-}
+
+-- This is a simple case that exercises the LocalGivenEqs bullet
+-- of Note [When does an implication have given equalities?] in GHC.Tc.Solver.Monad
+-- If a future change rejects this, that's not the end of the world, but it's nice
+-- to be able to infer `f`.
+
+module LocalGivenEqs2 where
+
+type family F a
+type family G b
+
+data T where
+  MkT :: F a ~ G b => a -> b -> T
+
+f (MkT _ _) = True
diff --git a/testsuite/tests/typecheck/should_compile/PolytypeDecomp.stderr b/testsuite/tests/typecheck/should_compile/PolytypeDecomp.stderr
index bde2a0d7037f11f7b6c86bf9da83eb2f7efac528..0f1fd3e6c2a5387c321b03a929253becf526b987 100644
--- a/testsuite/tests/typecheck/should_compile/PolytypeDecomp.stderr
+++ b/testsuite/tests/typecheck/should_compile/PolytypeDecomp.stderr
@@ -8,13 +8,3 @@ PolytypeDecomp.hs:30:17: error:
     • In the expression: x
       In the first argument of ‘myLength’, namely ‘[x, f]’
       In the expression: myLength [x, f]
-
-PolytypeDecomp.hs:30:19: error:
-    • Couldn't match type ‘a0’ with ‘[forall a. F [a]]’
-      Expected: Id a0
-        Actual: [forall a. F [a]]
-      Cannot instantiate unification variable ‘a0’
-      with a type involving polytypes: [forall a. F [a]]
-    • In the expression: f
-      In the first argument of ‘myLength’, namely ‘[x, f]’
-      In the expression: myLength [x, f]
diff --git a/testsuite/tests/typecheck/should_compile/T13651.stderr b/testsuite/tests/typecheck/should_compile/T13651.stderr
index 150291c210533aefda87221bdaf9559123be3c78..cc7af849d313f1ec949d14a30ecfe525b0e5235c 100644
--- a/testsuite/tests/typecheck/should_compile/T13651.stderr
+++ b/testsuite/tests/typecheck/should_compile/T13651.stderr
@@ -1,6 +1,6 @@
 
 T13651.hs:11:8: error:
-    • Could not deduce: F cr (Bar (Foo h) (Foo u)) ~ Bar h (Bar r u)
+    • Could not deduce: F cr (Bar h (Foo u)) ~ Bar h (Bar r u)
       from the context: (F cr cu ~ Bar h (Bar r u),
                          F cu cs ~ Bar (Foo h) (Bar u s))
         bound by the type signature for:
diff --git a/testsuite/tests/typecheck/should_compile/T15368.stderr b/testsuite/tests/typecheck/should_compile/T15368.stderr
index 7f022744c4b26af26802e3787e239c90851be92c..33b0407730c06b8410f0c1f61dcfa63c8dca6c9e 100644
--- a/testsuite/tests/typecheck/should_compile/T15368.stderr
+++ b/testsuite/tests/typecheck/should_compile/T15368.stderr
@@ -15,8 +15,8 @@ T15368.hs:11:15: warning: [-Wtyped-holes (in -Wdefault)]
         trigger :: a -> b -> (F a b, F b a) (bound at T15368.hs:11:1)
 
 T15368.hs:11:15: warning: [-Wdeferred-type-errors (in -Wdefault)]
-    • Couldn't match type: F b a
-                     with: F b0 a0
+    • Couldn't match type: F b0 a0
+                     with: F b a
       Expected: (F a b, F b a)
         Actual: (F a b, F b0 a0)
       NB: ‘F’ is a non-injective type family
diff --git a/testsuite/tests/typecheck/should_compile/T5490.hs b/testsuite/tests/typecheck/should_compile/T5490.hs
index b5b7a2d98cf4e9019ea73dc7093b149e85fa122c..5679ee9baaf5ec60f90a8a0d48db6c6f31d9ab45 100644
--- a/testsuite/tests/typecheck/should_compile/T5490.hs
+++ b/testsuite/tests/typecheck/should_compile/T5490.hs
@@ -16,7 +16,7 @@ import Data.Functor
 import Control.Exception
 
 data Attempt α = Success α
-               | ∀ e . Exception e ⇒ Failure e 
+               | ∀ e . Exception e ⇒ Failure e
 
 fromAttempt ∷ Attempt α → IO α
 fromAttempt (Success a) = return a
@@ -136,7 +136,7 @@ instance IsPeano PZero where
   peano = PZero
 
 instance IsPeano p ⇒ IsPeano (PSucc p) where
-  peano = PSucc peano 
+  peano = PSucc peano
 
 class (n ~ PSucc (PPred n)) ⇒ PHasPred n where
   type PPred n
@@ -297,4 +297,3 @@ hGetIfNth _        _                  = Nothing
 
 elem0 ∷ HNonEmpty l ⇒ HElemOf l → Maybe (HHead l)
 elem0 = hGetIfNth PZero
-
diff --git a/testsuite/tests/typecheck/should_compile/T9834.stderr b/testsuite/tests/typecheck/should_compile/T9834.stderr
index 5963781325e66395867905557ffb31bb978d18ec..2c410de0f27557f035b06138ea49f44b93e3c409 100644
--- a/testsuite/tests/typecheck/should_compile/T9834.stderr
+++ b/testsuite/tests/typecheck/should_compile/T9834.stderr
@@ -1,11 +1,14 @@
 
 T9834.hs:23:12: warning: [-Wdeferred-type-errors (in -Wdefault)]
-    • Couldn't match type ‘p’ with ‘(->) (p a0)’
+    • Couldn't match type ‘a’ with ‘p a0’
       Expected: p a
         Actual: p a0 -> p a0
-      ‘p’ is a rigid type variable bound by
-        the class declaration for ‘ApplicativeFix’
-        at T9834.hs:21:39
+      ‘a’ is a rigid type variable bound by
+        the type signature for:
+          afix :: forall a.
+                  (forall (q :: * -> *). Applicative q => Comp p q a -> Comp p q a)
+                  -> p a
+        at T9834.hs:22:11-74
     • In the expression: wrapIdComp f
       In an equation for ‘afix’: afix f = wrapIdComp f
     • Relevant bindings include
diff --git a/testsuite/tests/typecheck/should_compile/UnliftedNewtypesUnifySig.hs b/testsuite/tests/typecheck/should_compile/UnliftedNewtypesUnifySig.hs
index a7645a0b3ec83a0f0900ca9db05ff5d7695caf52..3984df496ac32ef4f66b4c0cf2c34231ba892b3f 100644
--- a/testsuite/tests/typecheck/should_compile/UnliftedNewtypesUnifySig.hs
+++ b/testsuite/tests/typecheck/should_compile/UnliftedNewtypesUnifySig.hs
@@ -20,4 +20,4 @@ data family D (a :: TYPE r) :: TYPE r
 newtype instance D a = MkWordD Word#
 
 newtype instance D a :: TYPE (KindOf a) where
-  MkIntD :: forall (a :: TYPE 'IntRep). Int# -> D a
+  MkIntD :: forall a. Int# -> D a
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 08f4b803c85164b2110804e7de8aecf9895a442d..5aeb4d0a58042000960c54a2c7b22be432e7e13f 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -731,3 +731,8 @@ test('T18939_Compile', normal, compile, [''])
 test('T15942', normal, compile, [''])
 test('ClassDefaultInHsBoot', [extra_files(['ClassDefaultInHsBootA1.hs','ClassDefaultInHsBootA2.hs','ClassDefaultInHsBootA2.hs-boot','ClassDefaultInHsBootA3.hs'])], multimod_compile, ['ClassDefaultInHsBoot', '-v0'])
 test('T17186', normal, compile, [''])
+test('CbvOverlap', normal, compile, [''])
+test('InstanceGivenOverlap', normal, compile, [''])
+test('InstanceGivenOverlap2', normal, compile, [''])
+test('LocalGivenEqs', normal, compile, [''])
+test('LocalGivenEqs2', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/ContextStack2.hs b/testsuite/tests/typecheck/should_fail/ContextStack2.hs
index 53634a5cd57da7c7e5b45df3bdf459ded12b0f23..0e01ab6956a37110b1b90e10e7bbf3b64c7c69cc 100644
--- a/testsuite/tests/typecheck/should_fail/ContextStack2.hs
+++ b/testsuite/tests/typecheck/should_fail/ContextStack2.hs
@@ -12,11 +12,11 @@ type instance TF (a,b) = (TF a, TF b)
 t :: (a ~ TF (a,Int)) => Int
 t = undefined
 
-{- a ~ TF (a,Int)  
+{- a ~ TF (a,Int)
      ~ (TF a, TF Int)
      ~ (TF (TF (a,Int)), TF Int)
      ~ (TF (TF a, TF Int), TF Int)
-     ~ ((TF (TF a), TF (TF Int)), TF Int) 
+     ~ ((TF (TF a), TF (TF Int)), TF Int)
 
 
       fsk ~ a
@@ -28,7 +28,7 @@ t = undefined
          a ~ (TF a, TF Int)
         (flatten rhs)
         a ~ (fsk1, TF Int)
-(wk)  TF a ~ fsk1   
+(wk)  TF a ~ fsk1
 
 --> (rewrite inert)
 
@@ -43,7 +43,7 @@ t = undefined
 *     TF (fsk1, fsk2) ~ fsk1
 (wk)  TF Tnt ~ fsk2
 
--->   
+-->
       fsk ~ (fsk1, TF Int)
       a   ~ (fsk1, TF Int)
 
@@ -51,7 +51,7 @@ t = undefined
         (flatten rhs)
         fsk1 ~ (fsk3, TF fsk2)
 
-   
+
 (wk)  TF Int ~ fsk2
       TF fsk1 ~ fsk3
 -}
diff --git a/testsuite/tests/typecheck/should_fail/GivenForallLoop.hs b/testsuite/tests/typecheck/should_fail/GivenForallLoop.hs
new file mode 100644
index 0000000000000000000000000000000000000000..a5f109949ce0f80f31272720b240039b32ba3a49
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/GivenForallLoop.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TypeFamilies, ImpredicativeTypes #-}
+
+module GivenForallLoop where
+
+type family F a b
+
+loopy :: (a ~ (forall b. F a b)) => a -> b
+loopy x = x
diff --git a/testsuite/tests/typecheck/should_fail/GivenForallLoop.stderr b/testsuite/tests/typecheck/should_fail/GivenForallLoop.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..e4260e62edba355232805df1dfb83f25cce2641f
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/GivenForallLoop.stderr
@@ -0,0 +1,20 @@
+
+GivenForallLoop.hs:8:11: error:
+    • Could not deduce: a ~ b
+      from the context: a ~ (forall b1. F a b1)
+        bound by the type signature for:
+                   loopy :: forall a b. (a ~ (forall b1. F a b1)) => a -> b
+        at GivenForallLoop.hs:7:1-42
+      ‘a’ is a rigid type variable bound by
+        the type signature for:
+          loopy :: forall a b. (a ~ (forall b1. F a b1)) => a -> b
+        at GivenForallLoop.hs:7:1-42
+      ‘b’ is a rigid type variable bound by
+        the type signature for:
+          loopy :: forall a b. (a ~ (forall b1. F a b1)) => a -> b
+        at GivenForallLoop.hs:7:1-42
+    • In the expression: x
+      In an equation for ‘loopy’: loopy x = x
+    • Relevant bindings include
+        x :: a (bound at GivenForallLoop.hs:8:7)
+        loopy :: a -> b (bound at GivenForallLoop.hs:8:1)
diff --git a/testsuite/tests/typecheck/should_fail/T15629.stderr b/testsuite/tests/typecheck/should_fail/T15629.stderr
index 3599acef73374b671b001e69564a5e281258b126..c1d751bee24708b8e1e3c3e9bb71ddc3aea54037 100644
--- a/testsuite/tests/typecheck/should_fail/T15629.stderr
+++ b/testsuite/tests/typecheck/should_fail/T15629.stderr
@@ -1,17 +1,26 @@
 
-T15629.hs:26:37: error:
+T15629.hs:26:31: error:
     • Couldn't match kind ‘z’ with ‘ab’
-      Expected kind ‘x ~> F x ab’,
-        but ‘F1Sym :: x ~> F x z’ has kind ‘x ~> F x z’
+      Expected kind ‘F x ab ~> F x ab’,
+        but ‘Comp (F1Sym :: x ~> F x z) F2Sym’ has kind ‘TyFun
+                                                           (F x ab) (F x z)
+                                                         -> *’
       ‘z’ is a rigid type variable bound by
         an explicit forall z ab
         at T15629.hs:26:17
       ‘ab’ is a rigid type variable bound by
         an explicit forall z ab
         at T15629.hs:26:19-20
-    • In the first argument of ‘Comp’, namely ‘(F1Sym :: x ~> F x z)’
-      In the first argument of ‘Proxy’, namely
+    • In the first argument of ‘Proxy’, namely
         ‘((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab)’
       In the type signature:
-        g :: forall z ab. Proxy ((Comp (F1Sym :: x
-                                                 ~> F x z) F2Sym) :: F x ab ~> F x ab)
+        g :: forall z ab.
+             Proxy ((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab)
+      In an equation for ‘f’:
+          f _
+            = ()
+            where
+                g ::
+                  forall z ab.
+                  Proxy ((Comp (F1Sym :: x ~> F x z) F2Sym) :: F x ab ~> F x ab)
+                g = sg Proxy Proxy
diff --git a/testsuite/tests/typecheck/should_fail/T16512a.stderr b/testsuite/tests/typecheck/should_fail/T16512a.stderr
index f18e9738bfeb3dee0ca38d0f8903c10cacc53b11..a799bcca21d812787fd39413ed38ce86a102a689 100644
--- a/testsuite/tests/typecheck/should_fail/T16512a.stderr
+++ b/testsuite/tests/typecheck/should_fail/T16512a.stderr
@@ -1,12 +1,16 @@
 
 T16512a.hs:41:25: error:
-    • Reduction stack overflow; size = 201
-      When simplifying the following type: ListVariadic as b
-      Use -freduction-depth=0 to disable this check
-      (any upper bound you could choose might fail unpredictably with
-       minor updates to GHC, so disabling the check is recommended if
-       you're sure that type checking should terminate)
+    • Couldn't match type: ListVariadic as (a -> b)
+                     with: a -> ListVariadic as b
+      Expected: AST (ListVariadic (a : as) b)
+        Actual: AST (ListVariadic as (a -> b))
     • In the first argument of ‘AnApplication’, namely ‘g’
       In the expression: AnApplication g (a `ConsAST` as)
       In a case alternative:
           AnApplication g as -> AnApplication g (a `ConsAST` as)
+    • Relevant bindings include
+        as :: ASTs as (bound at T16512a.hs:40:25)
+        g :: AST (ListVariadic as (a -> b)) (bound at T16512a.hs:40:23)
+        a :: AST a (bound at T16512a.hs:38:15)
+        f :: AST (a -> b) (bound at T16512a.hs:38:10)
+        unapply :: AST b -> AnApplication b (bound at T16512a.hs:38:1)
diff --git a/testsuite/tests/typecheck/should_fail/T3406.stderr b/testsuite/tests/typecheck/should_fail/T3406.stderr
index 70fffee3ac715fb29af9d4b95f1ac95a689c51b7..70791b2cdc3bb5f605cea8b4362917ba0920b0cb 100644
--- a/testsuite/tests/typecheck/should_fail/T3406.stderr
+++ b/testsuite/tests/typecheck/should_fail/T3406.stderr
@@ -1,6 +1,6 @@
 
 T3406.hs:11:28: error:
-    • Couldn't match type ‘Int’ with ‘a -> ItemColID a b’
+    • Couldn't match type ‘Int’ with ‘a -> Int’
       Expected: a -> ItemColID a b
         Actual: ItemColID a1 b1
     • In the expression: x :: ItemColID a b
diff --git a/testsuite/tests/typecheck/should_fail/T5853.stderr b/testsuite/tests/typecheck/should_fail/T5853.stderr
index 5d426257968a080441be6623e82ba1233607ecdd..b25e1fca91d6c6d36c3c52e230ebea63f83debc3 100644
--- a/testsuite/tests/typecheck/should_fail/T5853.stderr
+++ b/testsuite/tests/typecheck/should_fail/T5853.stderr
@@ -1,16 +1,18 @@
 
 T5853.hs:15:52: error:
-    • Could not deduce: Subst (Subst fa a) b ~ Subst fa b
+    • Could not deduce: Subst fa1 (Elem fb) ~ fb
         arising from a use of ‘<$>’
-      from the context: (F fa, Elem (Subst fa b) ~ b,
-                         Subst fa b ~ Subst fa b, Subst (Subst fa b) (Elem fa) ~ fa,
-                         F (Subst fa a), Elem (Subst fa a) ~ a, Elem fa ~ Elem fa,
-                         Subst (Subst fa a) (Elem fa) ~ fa, Subst fa a ~ Subst fa a)
+      from the context: (F fa, Elem fb ~ Elem fb,
+                         Subst fa (Elem fb) ~ fb, Subst fb (Elem fa) ~ fa, F fa1,
+                         Elem fa1 ~ Elem fa1, Elem fa ~ Elem fa, Subst fa1 (Elem fa) ~ fa,
+                         Subst fa (Elem fa1) ~ fa1)
         bound by the RULE "map/map" at T5853.hs:15:2-57
-      NB: ‘Subst’ is a non-injective type family
+      ‘fb’ is a rigid type variable bound by
+        the RULE "map/map"
+        at T5853.hs:15:2-57
     • In the expression: (f . g) <$> xs
       When checking the rewrite rule "map/map"
     • Relevant bindings include
-        f :: Elem fa -> b (bound at T5853.hs:15:19)
-        g :: a -> Elem fa (bound at T5853.hs:15:21)
-        xs :: Subst fa a (bound at T5853.hs:15:23)
+        f :: Elem fa -> Elem fb (bound at T5853.hs:15:19)
+        g :: Elem fa1 -> Elem fa (bound at T5853.hs:15:21)
+        xs :: fa1 (bound at T5853.hs:15:23)
diff --git a/testsuite/tests/typecheck/should_fail/T8142.stderr b/testsuite/tests/typecheck/should_fail/T8142.stderr
index a9f4590e449e215c4163e30f1837c58df3aa8cdc..a362d35367f2a10b2c1a358ae83c86252d9424ce 100644
--- a/testsuite/tests/typecheck/should_fail/T8142.stderr
+++ b/testsuite/tests/typecheck/should_fail/T8142.stderr
@@ -1,10 +1,10 @@
 
 T8142.hs:6:10: error:
-    • Couldn't match type: Nu ((,) a0)
+    • Couldn't match type: Nu f0
                      with: c -> f c
       Expected: (c -> f c) -> c -> f c
         Actual: Nu ((,) a0) -> Nu f0
-      The type variable ‘a0’ is ambiguous
+      The type variable ‘f0’ is ambiguous
     • In the expression: h
       In an equation for ‘tracer’:
           tracer
@@ -12,15 +12,17 @@ T8142.hs:6:10: error:
             where
                 h = (\ (_, b) -> ((outI . fmap h) b)) . out
     • Relevant bindings include
+        h :: Nu ((,) a0) -> Nu f0 (bound at T8142.hs:6:18)
         tracer :: (c -> f c) -> c -> f c (bound at T8142.hs:6:1)
 
 T8142.hs:6:57: error:
-    • Couldn't match type: Nu ((,) a)
-                     with: f1 (Nu ((,) a))
-      Expected: Nu ((,) a) -> (a, f1 (Nu ((,) a)))
-        Actual: Nu ((,) a) -> (a, Nu ((,) a))
+    • Couldn't match type: Nu ((,) a0)
+                     with: f0 (Nu ((,) a0))
+      Expected: Nu ((,) a0) -> (a0, f0 (Nu ((,) a0)))
+        Actual: Nu ((,) a0) -> (a0, Nu ((,) a0))
+      The type variables ‘f0’, ‘a0’ are ambiguous
     • In the second argument of ‘(.)’, namely ‘out’
       In the expression: (\ (_, b) -> ((outI . fmap h) b)) . out
       In an equation for ‘h’: h = (\ (_, b) -> ((outI . fmap h) b)) . out
     • Relevant bindings include
-        h :: Nu ((,) a) -> Nu f1 (bound at T8142.hs:6:18)
+        h :: Nu ((,) a0) -> Nu f0 (bound at T8142.hs:6:18)
diff --git a/testsuite/tests/typecheck/should_fail/T9260.stderr b/testsuite/tests/typecheck/should_fail/T9260.stderr
index 2a6c0ac16c679723cb765f1b393d761e8d5ea75d..b3752e4279301c531bc45e97451389b0be5bcedb 100644
--- a/testsuite/tests/typecheck/should_fail/T9260.stderr
+++ b/testsuite/tests/typecheck/should_fail/T9260.stderr
@@ -1,8 +1,7 @@
 
-T9260.hs:12:14: error:
-    • Couldn't match type ‘1’ with ‘0’
-      Expected: Fin 0
-        Actual: Fin (0 + 1)
-    • In the first argument of ‘Fsucc’, namely ‘Fzero’
-      In the expression: Fsucc Fzero
+T9260.hs:12:8: error:
+    • Couldn't match type ‘2’ with ‘1’
+      Expected: Fin 1
+        Actual: Fin ((0 + 1) + 1)
+    • In the expression: Fsucc Fzero
       In an equation for ‘test’: test = Fsucc Fzero
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 5ce09273a28f4979a2a04ccfb1d0ee6734964cf1..958811d4284d4bc8ddacbe8efab303f3a1adf86c 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -590,3 +590,4 @@ test('T18640b', normal, compile_fail, [''])
 test('T18640c', normal, compile_fail, [''])
 test('T10709', normal, compile_fail, [''])
 test('T10709b', normal, compile_fail, [''])
+test('GivenForallLoop', normal, compile_fail, [''])
diff --git a/utils/haddock b/utils/haddock
index 2d06af2fc535dacc4bac45d45e8eb95a7620caac..8d260690b53f2fb6b54ba78bd13d1400d9ebd395 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 2d06af2fc535dacc4bac45d45e8eb95a7620caac
+Subproject commit 8d260690b53f2fb6b54ba78bd13d1400d9ebd395