Simon's major commit to re-engineer the constraint solverwip/new-flatten-skolems-Oct14

The driving change is this:

* The canonical CFunEqCan constraints now have the form
       [G] F xis ~ fsk
       [W] F xis ~ fmv
  where fsk is a flatten-skolem, and fmv is a flatten-meta-variable
  Think of them as the name of the type-function application

See Note [The flattening story] in TcFlatten.  A flatten-meta-variable
is distinguishable by its MetaInfo of FlatMetaTv

This in turn led to an enormous cascade of other changes, which simplify
and modularise the constraint solver.  In particular:

* Basic data types
    * I got rid of inert_solved_funeqs altogether. It serves no useful
      role that inert_flat_cache does not solve.

    * I added wl_implics to the WorkList, as a convenient place to
      accumulate newly-emitted implications; see Note [Residual
      implications] in TcSMonad.

    * I eliminated tcs_ty_binds altogether. These were the bindings
      for unification variables that we have now solved by
      unification.  We kept them in a finite map and did the
      side-effecting unification later.  But in cannonicalisation we
      had to look up in the side-effected mutable tyvars anyway, so
      nothing was being gained.

      Our original idea was that the solver would be pure, and would
      be a no-op if you discarded its results, but this was already
      not-true for implications since we update their evidence
      bindings in an imperative way.  So rather than the uneasy
      compromise, it's now clearly imperative!

* I split out the flatten/unflatten code into a new module, TcFlatten

* I simplified and articulated explicitly the (rather hazy) invariants
  for the inert substitution inert_eqs.  See Note [eqCanRewrite] and
  See Note [Applying the inert substitution] in TcFlatten

* Unflattening is now done (by TcFlatten.unflatten) after solveFlats,
  before solving nested implications.  This turned out to simplify a
  lot of code. Previously, unflattening was done as part of zonking, at
  the very very end.

    * Eager unflattening allowed me to remove the unpleasant ic_fsks
      field of an Implication (hurrah)

    * Eager unflattening made the TcSimplify.floatEqualities function
      much simpler (just float equalities looking like a ~ ty, where a
      is an untouchable meta-tyvar).

    * Likewise the idea of "pushing wanteds in as givens" could be
      completely eliminated.

* I radically simplified the code that determines when there are
  'given' equalities, and hence whether we can float 'wanted' equalies
  out.  See TcSMonad.getNoGivenEqs, and Note [When does an implication
  have given equalities?].

  This allowed me to get rid of the unpleasant inert_no_eqs flag in InertCans.

* As part of this given-equality stuff, I fixed Trac #9211. See Note
  [Let-bound skolems] in TcSMonad

* Orientation of tyvar/tyvar equalities (a ~ b) was partly done during
  canonicalisation, but then repeated in the spontaneous-solve stage
  (trySpontaneousSolveTwoWay). Now it is done exclusively during
  canonicalisation, which keeps all the code in one place.  See
  Note [Canonical orientation for tyvar/tyvar equality constraints]
  in TcCanonical

13 files changed, 2842 insertions, 2218 deletions

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 0932749649..6422eb7ce9 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -406,6 +406,7 @@ Library
         TcUnify
         TcInteract
         TcCanonical
+        TcFlatten
         TcSMonad
         TcTypeNats
         TcSplice
diff --git a/compiler/typecheck/Flattening-notes b/compiler/typecheck/Flattening-notes
index 5f6fd140c8..ec4565ccf5 100644
--- a/compiler/typecheck/Flattening-notes
+++ b/compiler/typecheck/Flattening-notes
@@ -2,22 +2,13 @@ ToDo:
 
 * get rid of getEvTerm?
 
-* Float only CTyEqCans.   kind-incompatible things should be CNonCanonical,
-  so they won't float and generate a duplicate kind-unify message
-
-  Then we can stop disabling floating when there are insolubles,
-  and that will improve mc21 etc
-
-* Note [Do not add duplicate derived isols]
-  This mostly doesn't apply now, except for the fundeps
-
 * inert_funeqs, inert_eqs: keep only the CtEvidence.
    They are all CFunEqCans, CTyEqCans
 
-* remove/rewrite TcMType Note [Unflattening while zonking]
-
 * Consider individual data tpyes for CFunEqCan etc
 
+* Collapes CNonCanonical and CIrredCan
+
 Remaining errors
 ============================
 Unexpected failures:
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index cc6f7594d4..17366a3aa2 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -590,13 +590,12 @@ addClsInstsErr herald ispecs
 \begin{code}
 ---------------- Getting free tyvars -------------------------
 tyVarsOfCt :: Ct -> TcTyVarSet
--- NB: the
-tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })    = extendVarSet (tyVarsOfType xi) tv
-tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
-tyVarsOfCt (CDictCan { cc_tyargs = tys })               = tyVarsOfTypes tys
-tyVarsOfCt (CIrredEvCan { cc_ev = ev })                 = tyVarsOfType (ctEvPred ev)
-tyVarsOfCt (CHoleCan { cc_ev = ev })                    = tyVarsOfType (ctEvPred ev)
-tyVarsOfCt (CNonCanonical { cc_ev = ev })               = tyVarsOfType (ctEvPred ev)
+tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })     = extendVarSet (tyVarsOfType xi) tv
+tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) = extendVarSet (tyVarsOfTypes tys) fsk
+tyVarsOfCt (CDictCan { cc_tyargs = tys })                = tyVarsOfTypes tys
+tyVarsOfCt (CIrredEvCan { cc_ev = ev })                  = tyVarsOfType (ctEvPred ev)
+tyVarsOfCt (CHoleCan { cc_ev = ev })                     = tyVarsOfType (ctEvPred ev)
+tyVarsOfCt (CNonCanonical { cc_ev = ev })                = tyVarsOfType (ctEvPred ev)
 
 tyVarsOfCts :: Cts -> TcTyVarSet
 tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
@@ -610,10 +609,10 @@ tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
 
 tyVarsOfImplic :: Implication -> TyVarSet
 -- Only called on *zonked* things, hence no need to worry about flatten-skolems
-tyVarsOfImplic (Implic { ic_skols = skols, ic_fsks = fsks
-                             , ic_given = givens, ic_wanted = wanted })
+tyVarsOfImplic (Implic { ic_skols = skols
+                       , ic_given = givens, ic_wanted = wanted })
   = (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens))
-    `delVarSetList` skols `delVarSetList` fsks
+    `delVarSetList` skols
 
 tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
 tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index d58d5db40f..dddceb63b5 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -1,10 +1,7 @@
 \begin{code}
 {-# LANGUAGE CPP #-}
 
-module TcCanonical(
-    canonicalize, emitWorkNC,
-    StopOrContinue (..)
- ) where
+module TcCanonical( canonicalize ) where
 
 #include "HsVersions.h"
 
@@ -12,23 +9,22 @@ import TcRnTypes
 import TcType
 import Type
 import Kind
+import TcFlatten
+import TcSMonad
 import TcEvidence
 import Class
 import TyCon
 import TypeRep
 import Var
-import VarEnv
+import Name( isSystemName )
 import OccName( OccName )
 import Outputable
 import Control.Monad    ( when )
 import DynFlags( DynFlags )
 import VarSet
-import TcSMonad
-import FastString
 
 import Util
 import BasicTypes
-import Maybes( catMaybes )
 \end{code}
 
 
@@ -71,35 +67,6 @@ phase cannot be rewritten any further from the inerts (but maybe /it/ can
 rewrite an inert or still interact with an inert in a further phase in the
 simplifier.
 
-\begin{code}
-
--- Informative results of canonicalization
-data StopOrContinue
-  = ContinueWith Ct   -- Either no canonicalization happened, or if some did
-                      -- happen, it is still safe to just keep going with this
-                      -- work item.
-  | Stop              -- Some canonicalization happened, extra work is now in
-                      -- the TcS WorkList.
-
-instance Outputable StopOrContinue where
-  ppr Stop             = ptext (sLit "Stop")
-  ppr (ContinueWith w) = ptext (sLit "ContinueWith") <+> ppr w
-
-
-continueWith :: Ct -> TcS StopOrContinue
-continueWith = return . ContinueWith
-
-andWhenContinue :: TcS StopOrContinue
-                -> (Ct -> TcS StopOrContinue)
-                -> TcS StopOrContinue
-andWhenContinue tcs1 tcs2
-  = do { r <- tcs1
-       ; case r of
-           Stop            -> return Stop
-           ContinueWith ct -> tcs2 ct }
-
-\end{code}
-
 Note [Caching for canonicals]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Our plan with pre-canonicalization is to be able to solve a constraint
@@ -158,7 +125,7 @@ EvBinds, so we are again good.
 -- Top-level canonicalization
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-canonicalize :: Ct -> TcS StopOrContinue
+canonicalize :: Ct -> TcS (StopOrContinue Ct)
 canonicalize ct@(CNonCanonical { cc_ev = ev })
   = do { traceTcS "canonicalize (non-canonical)" (ppr ct)
        ; {-# SCC "canEvVar" #-}
@@ -178,16 +145,16 @@ canonicalize (CTyEqCan { cc_ev = ev
 canonicalize (CFunEqCan { cc_ev = ev
                         , cc_fun    = fn
                         , cc_tyargs = xis1
-                        , cc_rhs    = xi2 })
+                        , cc_fsk    = fsk })
   = {-# SCC "canEqLeafFunEq" #-}
-    canEqLeafFun ev NotSwapped fn xis1 xi2 xi2
+    canCFunEqCan ev fn xis1 fsk
 
 canonicalize (CIrredEvCan { cc_ev = ev })
   = canIrred ev
 canonicalize (CHoleCan { cc_ev = ev, cc_occ = occ })
   = canHole ev occ
 
-canEvNC :: CtEvidence -> TcS StopOrContinue
+canEvNC :: CtEvidence -> TcS (StopOrContinue Ct)
 -- Called only for non-canonical EvVars
 canEvNC ev
   = case classifyPredType (ctEvPred ev) of
@@ -205,13 +172,13 @@ canEvNC ev
 %************************************************************************
 
 \begin{code}
-canTuple :: CtEvidence -> [PredType] -> TcS StopOrContinue
+canTuple :: CtEvidence -> [PredType] -> TcS (StopOrContinue Ct)
 canTuple ev tys
   = do { traceTcS "can_pred" (text "TuplePred!")
        ; let xcomp = EvTupleMk
              xdecomp x = zipWith (\_ i -> EvTupleSel x i) tys [0..]
-       ; ctevs <- xCtEvidence ev (XEvTerm tys xcomp xdecomp)
-       ; canEvVarsCreated ctevs }
+       ; xCtEvidence ev (XEvTerm tys xcomp xdecomp)
+       ; stopWith ev "Decomposed tuple constraint" }
 \end{code}
 
 %************************************************************************
@@ -223,7 +190,7 @@ canTuple ev tys
 \begin{code}
 canClass, canClassNC
    :: CtEvidence
-   -> Class -> [Type] -> TcS StopOrContinue
+   -> Class -> [Type] -> TcS (StopOrContinue Ct)
 -- Precondition: EvVar is class evidence
 
 -- The canClassNC version is used on non-canonical constraints
@@ -236,19 +203,18 @@ canClassNC ev cls tys
     `andWhenContinue` emitSuperclasses
 
 canClass ev cls tys
-  = do { (xis, cos) <- flattenMany FMFullFlatten ev tys
+  = do { let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll }
+       ; (xis, cos) <- flattenMany fmode tys
        ; let co = mkTcTyConAppCo Nominal (classTyCon cls) cos
              xi = mkClassPred cls xis
+             mk_ct new_ev = CDictCan { cc_ev = new_ev
+                                     , cc_tyargs = xis, cc_class = cls }
        ; mb <- rewriteEvidence ev xi co
        ; traceTcS "canClass" (vcat [ ppr ev <+> ppr cls <+> ppr tys
                                    , ppr xi, ppr mb ])
-       ; case mb of
-           Nothing -> return Stop
-           Just new_ev -> continueWith $
-                          CDictCan { cc_ev = new_ev
-                                   , cc_tyargs = xis, cc_class = cls } }
+       ; return (fmap mk_ct mb) }
 
-emitSuperclasses :: Ct -> TcS StopOrContinue
+emitSuperclasses :: Ct -> TcS (StopOrContinue Ct)
 emitSuperclasses ct@(CDictCan { cc_ev = ev , cc_tyargs = xis_new, cc_class = cls })
             -- Add superclasses of this one here, See Note [Adding superclasses].
             -- But only if we are not simplifying the LHS of a rule.
@@ -337,8 +303,7 @@ newSCWorkFromFlavored flavor cls xis
              xev = XEvTerm { ev_preds  =  sc_theta
                            , ev_comp   = panic "Can't compose for given!"
                            , ev_decomp = xev_decomp }
-       ; ctevs <- xCtEvidence flavor xev
-       ; emitWorkNC ctevs }
+       ; xCtEvidence flavor xev }
 
   | isEmptyVarSet (tyVarsOfTypes xis)
   = return () -- Wanteds with no variables yield no deriveds.
@@ -347,20 +312,19 @@ newSCWorkFromFlavored flavor cls xis
   | otherwise -- Wanted case, just add those SC that can lead to improvement.
   = do { let sc_rec_theta = transSuperClasses cls xis
              impr_theta   = filter is_improvement_pty sc_rec_theta
-             loc          = ctev_loc flavor
+             loc          = ctEvLoc flavor
        ; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta
-       ; mb_der_evs <- mapM (newDerived loc) impr_theta
-       ; emitWorkNC (catMaybes mb_der_evs) }
+       ; mapM_ (emitNewDerived loc) impr_theta }
 
 is_improvement_pty :: PredType -> Bool
 -- Either it's an equality, or has some functional dependency
 is_improvement_pty ty = go (classifyPredType ty)
   where
-    go (EqPred {})         = True
+    go (EqPred t1 t2)       = not (t1 `tcEqType` t2)
     go (ClassPred cls _tys) = not $ null fundeps
-      where (_,fundeps) = classTvsFds cls
-    go (TuplePred ts)      = any is_improvement_pty ts
-    go (IrredPred {})      = True -- Might have equalities after reduction?
+                            where (_,fundeps) = classTvsFds cls
+    go (TuplePred ts)       = any is_improvement_pty ts
+    go (IrredPred {})       = True -- Might have equalities after reduction?
 \end{code}
 
 
@@ -372,16 +336,18 @@ is_improvement_pty ty = go (classifyPredType ty)
 
 
 \begin{code}
-canIrred :: CtEvidence -> TcS StopOrContinue
+canIrred :: CtEvidence -> TcS (StopOrContinue Ct)
 -- Precondition: ty not a tuple and no other evidence form
 canIrred old_ev
   = do { let old_ty = ctEvPred old_ev
+             fmode  = FE { fe_ev = old_ev, fe_mode = FM_FlattenAll }
+                      -- Flatten (F [a]), say, so that it can reduce to Eq a
        ; traceTcS "can_pred" (text "IrredPred = " <+> ppr old_ty)
-       ; (xi,co) <- flatten FMFullFlatten old_ev old_ty -- co :: xi ~ old_ty
+       ; (xi,co) <- flatten fmode old_ty -- co :: xi ~ old_ty
        ; mb <- rewriteEvidence old_ev xi co
        ; case mb of {
-             Nothing     -> return Stop ;
-             Just new_ev ->
+             Stop ev s           -> return (Stop ev s) ;
+             ContinueWith new_ev ->
 
     do { -- Re-classify, in case flattening has improved its shape
        ; case classifyPredType (ctEvPred new_ev) of
@@ -391,340 +357,18 @@ canIrred old_ev
            _                 -> continueWith $
                                 CIrredEvCan { cc_ev = new_ev } } } }
 
-canHole :: CtEvidence -> OccName -> TcS StopOrContinue
+canHole :: CtEvidence -> OccName -> TcS (StopOrContinue Ct)
 canHole ev occ
-  = do { let ty = ctEvPred ev
-       ; (xi,co) <- flatten FMFullFlatten ev ty -- co :: xi ~ ty
+  = do { let ty    = ctEvPred ev
+             fmode = FE { fe_ev = ev, fe_mode = FM_SubstOnly }
+       ; (xi,co) <- flatten fmode ty -- co :: xi ~ ty
        ; mb <- rewriteEvidence ev xi co
        ; case mb of
-             Just new_ev -> emitInsoluble (CHoleCan { cc_ev = new_ev, cc_occ = occ })
-             Nothing     -> return ()   -- Found a cached copy; won't happen
-       ; return Stop }
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-%*        Flattening (eliminating all function symbols)                 *
-%*                                                                      *
-%************************************************************************
-
-Note [Flattening]
-~~~~~~~~~~~~~~~~~~~~
-  flatten ty  ==>   (xi, cc)
-    where
-      xi has no type functions, unless they appear under ForAlls
-
-      cc = Auxiliary given (equality) constraints constraining
-           the fresh type variables in xi.  Evidence for these
-           is always the identity coercion, because internally the
-           fresh flattening skolem variables are actually identified
-           with the types they have been generated to stand in for.
-
-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.
-
-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,
-it expands the synonym and proceeds; if not, it simply returns the
-unexpanded synonym.
-
-\begin{code}
-data FlattenMode = FMSubstOnly | FMFullFlatten
-                   -- See Note [Flattening under a forall]
-
--- Flatten a bunch of types all at once.
-flattenMany ::  FlattenMode
-            -> CtEvidence
-            -> [Type] -> TcS ([Xi], [TcCoercion])
--- Coercions :: Xi ~ Type
--- Returns True iff (no flattening happened)
--- NB: The EvVar inside the 'ctxt :: CtEvidence' is unused,
---     we merely want (a) Given/Solved/Derived/Wanted info
---                    (b) the GivenLoc/WantedLoc for when we create new evidence
-flattenMany f ctxt tys
-  = -- pprTrace "flattenMany" empty $
-    go tys
-  where go []       = return ([],[])
-        go (ty:tys) = do { (xi,co)    <- flatten f ctxt ty
-                         ; (xis,cos)  <- go tys
-                         ; return (xi:xis,co:cos) }
-
-flatten :: FlattenMode
-        -> CtEvidence -> TcType -> TcS (Xi, TcCoercion)
--- Flatten a type to get rid of type function applications, returning
--- the new type-function-free type, and a collection of new equality
--- constraints.  See Note [Flattening] for more detail.
---
--- Postcondition: Coercion :: Xi ~ TcType
-
-flatten _ _ xi@(LitTy {}) = return (xi, mkTcNomReflCo xi)
-
-flatten f ctxt (TyVarTy tv)
-  = flattenTyVar f ctxt tv
-
-flatten f ctxt (AppTy ty1 ty2)
-  = do { (xi1,co1) <- flatten f ctxt ty1
-       ; (xi2,co2) <- flatten f ctxt ty2
-       ; traceTcS "flatten/appty" (ppr ty1 $$ ppr ty2 $$ ppr xi1 $$ ppr co1 $$ ppr xi2 $$ ppr co2)
-       ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) }
-
-flatten f ctxt (FunTy ty1 ty2)
-  = do { (xi1,co1) <- flatten f ctxt ty1
-       ; (xi2,co2) <- flatten f ctxt ty2
-       ; return (mkFunTy xi1 xi2, mkTcFunCo Nominal co1 co2) }
-
-flatten f ctxt (TyConApp tc tys)
-
-  -- Expand type synonyms that mention type families 
-  -- on the RHS; see Note [Flattening synonyms]
-  | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
-  , any isSynFamilyTyCon (tyConsOfType rhs)
-  = flatten f ctxt (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
-
-  -- For * a normal data type application
-  --     * data family application
-  --     * type synonym application whose RHS does not mention type families
-  --             See Note [Flattening synonyms]
-  -- we just recursively flatten the arguments.
-  | not (isSynFamilyTyCon tc)
-  = do { (xis,cos) <- flattenMany f ctxt tys
-       ; return (mkTyConApp tc xis, mkTcTyConAppCo Nominal tc cos) }
-
-  -- 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.
-  | otherwise
-  = ASSERT( tyConArity tc <= length tys )       -- Type functions are saturated
-      do { (xis, cos) <- flattenMany f ctxt tys
-         ; let (xi_args,  xi_rest)  = splitAt (tyConArity tc) xis
-               (cos_args, cos_rest) = splitAt (tyConArity tc) cos
-                 -- The type function might be *over* saturated
-                 -- in which case the remaining arguments should
-                 -- be dealt with by AppTys
-
-         ; (rhs_xi, ret_co) <- flattenNestedFamApp f ctxt tc xi_args
-
-                  -- Emit the flat constraints
-         ; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable
-                                            --    cf Trac #5655
-                  , mkTcAppCos (mkTcSymCo ret_co `mkTcTransCo` mkTcTyConAppCo Nominal tc cos_args) $
-                    cos_rest
-                  )
-         }
-
-flatten _f ctxt ty@(ForAllTy {})
--- We allow for-alls when, but only when, no type function
--- applications inside the forall involve the bound type variables.
-  = do { let (tvs, rho) = splitForAllTys ty
-       ; (rho', co) <- flatten FMSubstOnly ctxt rho
-                         -- Substitute only under a forall
-                         -- See Note [Flattening under a forall]
-       ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) }
-\end{code}
-
-Note [Flattening synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-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 TcEvidence.
-
-But (Trac #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.
-
-
-Note [Flattening under a forall]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Under a forall, we
-  (a) MUST apply the inert substitution
-  (b) MUST NOT flatten type family applications
-Hence FMSubstOnly.
-
-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!
-
-\begin{code}
-flattenNestedFamApp :: FlattenMode -> CtEvidence
-                    -> TyCon -> [TcType]   -- Exactly-saturated type function application
-                    -> TcS (Xi, TcCoercion)
-flattenNestedFamApp FMSubstOnly _ tc xi_args
-  = do { let fam_ty = mkTyConApp tc xi_args
-       ; return (fam_ty, mkTcNomReflCo fam_ty) }
-
-flattenNestedFamApp FMFullFlatten ctxt tc xi_args  -- Eactly saturated
-  = do { let fam_ty = mkTyConApp tc xi_args
-       ; mb_ct <- lookupFlatEqn tc xi_args
-       ; case mb_ct of
-           Just (ctev, rhs_ty)
-             | ctev `canRewriteOrSame `ctxt    -- Must allow [W]/[W]
-             -> -- You may think that we can just return (cc_rhs ct) but not so.
-                --            return (mkTcCoVarCo (ctId ct), cc_rhs ct, [])
-                -- The cached constraint resides in the cache so we have to flatten
-                -- the rhs to make sure we have applied any inert substitution to it.
-                -- Alternatively we could be applying the inert substitution to the
-                -- cache as well when we interact an equality with the inert.
-                -- The design choice is: do we keep the flat cache rewritten or not?
-                -- For now I say we don't keep it fully rewritten.
-               do { (rhs_xi,co) <- flatten FMFullFlatten ctev rhs_ty
-                  ; let final_co = evTermCoercion (ctEvTerm ctev)
-                                   `mkTcTransCo` mkTcSymCo co
-                  ; traceTcS "flatten/flat-cache hit" $ (ppr ctev $$ ppr rhs_xi $$ ppr final_co)
-                  ; return (rhs_xi, final_co) }
-
-           _ -> do { (ctev, rhs_xi) <- newFlattenSkolem ctxt fam_ty
-                   ; extendFlatCache tc xi_args ctev rhs_xi
-
-                   -- The new constraint (F xi_args ~ rhs_xi) 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     = ctev
-                                        , cc_fun    = tc
-                                        , cc_tyargs = xi_args
-                                        , cc_rhs    = rhs_xi }
-                   ; updWorkListTcS $ extendWorkListFunEq ct
-
-                   ; traceTcS "flatten/flat-cache miss" $ (ppr fam_ty $$ ppr rhs_xi $$ ppr ctev)
-                   ; return (rhs_xi, evTermCoercion (ctEvTerm ctev)) }
-       }
-\end{code}
-
-\begin{code}
-flattenTyVar :: FlattenMode -> CtEvidence -> TcTyVar -> TcS (Xi, TcCoercion)
--- "Flattening" a type variable means to apply the substitution to it
--- The substitution is actually the union of the substitution in the TyBinds
--- for the unification variables that have been unified already with the inert
--- equalities, see Note [Spontaneously solved in TyBinds] in TcInteract.
---
--- Postcondition: co : xi ~ tv
-flattenTyVar f ctxt tv
-  = do { mb_yes <- flattenTyVarOuter f ctxt tv
-       ; case mb_yes of
-           Left tv'         -> -- Done 
-                               do { traceTcS "flattenTyVar1" (ppr tv $$ ppr (tyVarKind tv'))
-                                  ; return (ty', mkTcNomReflCo ty') }
-                            where
-                               ty' = mkTyVarTy tv'
-
-           Right (ty1, co1) -> -- Recurse
-                               do { (ty2, co2) <- flatten f ctxt ty1
-                                  ; traceTcS "flattenTyVar2" (ppr tv $$ ppr ty2)
-                                  ; return (ty2, co2 `mkTcTransCo` co1) }
-       }
-
-flattenTyVarOuter, flattenTyVarFinal 
-   :: FlattenMode -> CtEvidence
-   -> TcTyVar 
-   -> TcS (Either TyVar (TcType, TcCoercion))
--- Look up the tyvar in 
---   a) the internal MetaTyVar box
---   b) the tyvar binds 
---   c) the inerts
--- Return (Left tv')       if it is not found, tv' has a properly zonked kind
---        (Right (ty, co)) if found, with co :: ty ~ tv
---                         NB: in the latter case ty is not necessarily flattened
-
-flattenTyVarOuter f ctxt tv
-  | not (isTcTyVar tv)            -- Happens when flatten under a (forall a. ty)
-  = flattenTyVarFinal f ctxt tv   -- So ty contains refernces to the non-TcTyVar a
-  | otherwise
-  = do { mb_ty <- isFilledMetaTyVar_maybe tv
-       ; case mb_ty of {
-           Just ty -> do { traceTcS "Following filled tyvar" (ppr tv <+> equals <+> ppr ty)
-                         ; return (Right (ty, mkTcNomReflCo ty)) } ;
-           Nothing ->
-
-    -- Try in ty_binds
-    do { ty_binds <- getTcSTyBindsMap
-       ; case lookupVarEnv ty_binds tv of {
-           Just (_tv,ty) -> do { traceTcS "Following bound tyvar" (ppr tv <+> equals <+> ppr ty)
-                               ; return (Right (ty, mkTcNomReflCo ty)) } ;
-                                 -- NB: ty_binds coercions are all ReflCo,
-           Nothing ->
-
-    -- Try in the inert equalities
-    do { ieqs <- getInertEqs
-       ; case lookupVarEnv ieqs tv of
-           Just (ct:_)                      -- If the first doesn't work,
-             | let ctev   = ctEvidence ct   -- the subsequent ones won't either
-                   rhs_ty = cc_rhs ct
-             , ctev `canRewrite` ctxt 
-             ->  do { traceTcS "Following inert tyvar" (ppr tv <+> equals <+> ppr rhs_ty $$ ppr ctev)
-                    ; return (Right (rhs_ty, mkTcSymCo (evTermCoercion (ctEvTerm ctev)))) }
-                    -- NB: even if ct is Derived we are not going to
-                    -- touch the actual coercion so we are fine.
-
-           _other -> flattenTyVarFinal f ctxt tv
-    } } } } }
-
-flattenTyVarFinal f ctxt tv
-  = -- Done, but make sure the kind is zonked
-    do { let knd = tyVarKind tv
-       ; (new_knd, _kind_co) <- flatten f ctxt knd
-       ; return (Left (setVarType tv new_knd)) }
+           ContinueWith new_ev -> do { emitInsoluble (CHoleCan { cc_ev = new_ev, cc_occ = occ })
+                                     ; stopWith new_ev "Emit insoluble hole" }
+           Stop ev s -> return (Stop ev s) } -- Found a cached copy; won't happen
 \end{code}
 
-Note [Non-idempotent inert substitution]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The inert substitution is not idempotent in the broad sense. It is only idempotent in
-that it cannot rewrite the RHS of other inert equalities any further. An example of such
-an inert substitution is:
-
- [G] g1 : ta8 ~ ta4
- [W] g2 : ta4 ~ a5Fj
-
-Observe that the wanted cannot rewrite the solved goal, despite the fact that ta4 appears on
-an RHS of an equality. Now, imagine a constraint:
-
- [W] g3: ta8 ~ Int
-
-coming in. If we simply apply once the inert substitution we will get:
-
- [W] g3_1: ta4 ~ Int
-
-and because potentially ta4 is untouchable we will try to insert g3_1 in the inert set,
-getting a panic since the inert only allows ONE equation per LHS type variable (as it
-should).
-
-For this reason, when we reach to flatten a type variable, we flatten it recursively,
-so that we can make sure that the inert substitution /is/ fully applied.
-
-Insufficient (non-recursive) rewriting was the reason for #5668.
-
-
 %************************************************************************
 %*                                                                      *
 %*        Equalities
@@ -732,32 +376,14 @@ Insufficient (non-recursive) rewriting was the reason for #5668.
 %************************************************************************
 
 \begin{code}
-canEvVarsCreated :: [CtEvidence] -> TcS StopOrContinue
-canEvVarsCreated [] = return Stop
-    -- Add all but one to the work list
-    -- and return the first (if any) for futher processing
-canEvVarsCreated (ev : evs)
-  = do { emitWorkNC evs; canEvNC ev }
-          -- Note the "NC": these are fresh goals, not necessarily canonical
-
-emitWorkNC :: [CtEvidence] -> TcS ()
-emitWorkNC evs
-  | null evs  = return ()
-  | otherwise = do { traceTcS "Emitting fresh work" (vcat (map ppr evs))
-                   ; updWorkListTcS (extendWorkListCts (map mk_nc evs)) }
-  where
-    mk_nc ev = mkNonCanonical ev
-
--------------------------
-canEqNC :: CtEvidence -> Type -> Type -> TcS StopOrContinue
+canEqNC :: CtEvidence -> Type -> Type -> TcS (StopOrContinue Ct)
 canEqNC ev ty1 ty2 = can_eq_nc ev ty1 ty1 ty2 ty2
 
-
 can_eq_nc, can_eq_nc' 
    :: CtEvidence 
    -> Type -> Type    -- LHS, after and before type-synonym expansion, resp 
    -> Type -> Type    -- RHS, after and before type-synonym expansion, resp 
-   -> TcS StopOrContinue
+   -> TcS (StopOrContinue Ct)
 
 can_eq_nc ev ty1 ps_ty1 ty2 ps_ty2
   = do { traceTcS "can_eq_nc" $ 
@@ -769,13 +395,13 @@ can_eq_nc' ev ty1 ps_ty1 ty2 ps_ty2
   | Just ty1' <- tcView ty1 = can_eq_nc ev ty1' ps_ty1 ty2  ps_ty2
   | Just ty2' <- tcView ty2 = can_eq_nc ev ty1  ps_ty1 ty2' ps_ty2
 
--- Type family on LHS or RHS take priority
-can_eq_nc' ev (TyConApp fn tys) _ ty2 ps_ty2
-  | isSynFamilyTyCon fn
-  = canEqLeafFun ev NotSwapped fn tys ty2 ps_ty2
-can_eq_nc' ev ty1 ps_ty1 (TyConApp fn tys) _
-  | isSynFamilyTyCon fn
-  = canEqLeafFun ev IsSwapped fn tys ty1 ps_ty1
+-- Type family on LHS or RHS take priority over tyvars,
+-- so that  tv ~ F ty gets flattened
+-- Otherwise  F a ~ F a  might not get solved!
+can_eq_nc' ev (TyConApp fn1 tys1) _ ty2 ps_ty2
+  | isSynFamilyTyCon fn1 = can_eq_fam_nc ev NotSwapped fn1 tys1 ty2 ps_ty2
+can_eq_nc' ev ty1 ps_ty1 (TyConApp fn2 tys2) _
+  | isSynFamilyTyCon fn2 = can_eq_fam_nc ev IsSwapped fn2 tys2 ty1 ps_ty1
 
 -- Type variable on LHS or RHS are next
 can_eq_nc' ev (TyVarTy tv1) _ ty2 ps_ty2
@@ -792,7 +418,7 @@ can_eq_nc' ev ty1@(LitTy l1) _ (LitTy l2) _
  | l1 == l2
   = do { when (isWanted ev) $
          setEvBind (ctev_evar ev) (EvCoercion (mkTcNomReflCo ty1))
-       ; return Stop }
+       ; stopWith ev "Equal LitTy" }
 
 -- Decomposable type constructor applications 
 -- Synonyms and type functions (which are not decomposable)
@@ -826,11 +452,11 @@ can_eq_nc' ev s1@(ForAllTy {}) _ s2@(ForAllTy {}) _
           do { traceTcS "Creating implication for polytype equality" $ ppr ev
              ; ev_term <- deferTcSForAllEq Nominal loc (tvs1,body1) (tvs2,body2)
              ; setEvBind orig_ev ev_term
-             ; return Stop } }
+             ; stopWith ev "Deferred polytype equality" } }
  | otherwise
  = do { traceTcS "Ommitting decomposition of given polytype equality" $
         pprEq s1 s2    -- See Note [Do not decompose given polytype equalities]
-      ; return Stop }
+      ; stopWith ev "Discard given polytype equality" }
 
 can_eq_nc' ev (AppTy s1 t1) ps_ty1 ty2 ps_ty2
   = can_eq_app ev NotSwapped s1 t1 ps_ty1 ty2 ps_ty2
@@ -842,21 +468,38 @@ can_eq_nc' ev _ ps_ty1 _ ps_ty2
   = canEqFailure ev ps_ty1 ps_ty2
 
 ------------
+can_eq_fam_nc :: CtEvidence -> SwapFlag
+              -> TyCon -> [TcType]
+              -> TcType -> TcType
+              -> TcS (StopOrContinue Ct)
+-- Canonicalise a non-canonical equality of form (F tys ~ ty)
+--   or the swapped version thereof
+-- Flatten both sides and go round again
+can_eq_fam_nc ev swapped fn tys rhs ps_rhs
+  = do { let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll }
+       ; (xi_lhs, co_lhs) <- flattenFamApp fmode fn tys
+       ; mb_ct <- rewriteEqEvidence ev swapped xi_lhs rhs co_lhs (mkTcNomReflCo rhs)
+       ; case mb_ct of
+           Stop ev s           -> return (Stop ev s)
+           ContinueWith new_ev -> can_eq_nc new_ev xi_lhs xi_lhs rhs ps_rhs }
+
+------------
 can_eq_app, can_eq_flat_app
     :: CtEvidence -> SwapFlag
-    -> Type -> Type -> Type  -- LHS (s1 t2), after and before type-synonym expansion, resp 
-    -> Type -> Type          -- RHS (ty2),   after and before type-synonym expansion, resp 
-    -> TcS StopOrContinue
+    -> Type -> Type -> Type  -- LHS (s1 t2), after and before type-synonym expansion, resp
+    -> Type -> Type          -- RHS (ty2),   after and before type-synonym expansion, resp
+    -> TcS (StopOrContinue Ct)
 -- See Note [Canonicalising type applications]
 can_eq_app ev swapped s1 t1 ps_ty1 ty2 ps_ty2
   =  do { traceTcS "can_eq_app 1" $
           vcat [ ppr ev, ppr swapped, ppr s1, ppr t1, ppr ty2 ]
-        ; (xi_s1, co_s1) <- flatten FMSubstOnly ev s1
+        ; let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll }
+        ; (xi_s1, co_s1) <- flatten fmode s1
         ; traceTcS "can_eq_app 2" $ vcat [ ppr ev, ppr xi_s1 ]
         ; if s1 `tcEqType` xi_s1
           then can_eq_flat_app ev swapped s1 t1 ps_ty1 ty2 ps_ty2
           else
-     do { (xi_t1, co_t1) <- flatten FMSubstOnly ev t1
+     do { (xi_t1, co_t1) <- flatten fmode t1
              -- We flatten t1 as well so that (xi_s1 xi_t1) is well-kinded
              -- If we form (xi_s1 t1) that might (appear) ill-kinded, 
              -- and then crash in a call to typeKind
@@ -867,8 +510,8 @@ can_eq_app ev swapped s1 t1 ps_ty1 ty2 ps_ty2
                                      co1 (mkTcNomReflCo ps_ty2)
         ; traceTcS "can_eq_app 4" $ vcat [ ppr ev, ppr xi1, ppr co1 ]
         ; case mb_ct of
-           Nothing     -> return Stop
-           Just new_ev -> can_eq_nc new_ev xi1 xi1 ty2 ps_ty2 }}
+            Stop ev s           -> return (Stop ev s)
+            ContinueWith new_ev -> can_eq_nc new_ev xi1 xi1 ty2 ps_ty2 }}
 
 -- Preconditions: s1  is already flattened
 --                ty2 is not a type variable, so flattening
@@ -887,15 +530,15 @@ can_eq_flat_app ev swapped s1 t1 ps_ty1 ty2 ps_ty2
                  xevdecomp x = let xco = evTermCoercion x
                                in [ EvCoercion (mkTcLRCo CLeft xco)
                                   , EvCoercion (mkTcLRCo CRight xco)]
-           ; ctevs <- xCtEvidence ev (XEvTerm [mkTcEqPred s1 s2, mkTcEqPred t1 t2] xevcomp xevdecomp)
-           ; canEvVarsCreated ctevs }
+           ; xCtEvidence ev (XEvTerm [mkTcEqPred s1 s2, mkTcEqPred t1 t2] xevcomp xevdecomp)
+           ; stopWith ev "Decomposed AppTy" }
 
 
 ------------------------
 canDecomposableTyConApp :: CtEvidence
                         -> TyCon -> [TcType]
                         -> TyCon -> [TcType]
-                        -> TcS StopOrContinue
+                        -> TcS (StopOrContinue Ct)
 canDecomposableTyConApp ev tc1 tys1 tc2 tys2
   | tc1 /= tc2 || length tys1 /= length tys2
     -- Fail straight away for better error messages
@@ -906,25 +549,26 @@ canDecomposableTyConApp ev tc1 tys1 tc2 tys2
 
 canDecomposableTyConAppOK :: CtEvidence
                           -> TyCon -> [TcType] -> [TcType]
-                          -> TcS StopOrContinue
+                          -> TcS (StopOrContinue Ct)
 
 canDecomposableTyConAppOK ev tc1 tys1 tys2
   = do { let xcomp xs  = EvCoercion (mkTcTyConAppCo Nominal tc1 (map evTermCoercion xs))
              xdecomp x = zipWith (\_ i -> EvCoercion $ mkTcNthCo i (evTermCoercion x)) tys1 [0..]
              xev = XEvTerm (zipWith mkTcEqPred tys1 tys2) xcomp xdecomp
-       ; ctevs <- xCtEvidence ev xev
-       ; canEvVarsCreated ctevs }
+       ; xCtEvidence ev xev
+       ; stopWith ev "Decomposed TyConApp" }
 
-canEqFailure :: CtEvidence -> TcType -> TcType -> TcS StopOrContinue
+canEqFailure :: CtEvidence -> TcType -> TcType -> TcS (StopOrContinue Ct)
 -- See Note [Make sure that insolubles are fully rewritten]
 canEqFailure ev ty1 ty2
-  = do { (s1, co1) <- flatten FMSubstOnly ev ty1
-       ; (s2, co2) <- flatten FMSubstOnly ev ty2
+  = do { let fmode = FE { fe_ev = ev, fe_mode = FM_SubstOnly }
+       ; (s1, co1) <- flatten fmode ty1
+       ; (s2, co2) <- flatten fmode ty2
        ; mb_ct <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2
        ; case mb_ct of
-           Just new_ev -> emitInsoluble (mkNonCanonical new_ev)
-           Nothing -> pprPanic "canEqFailure" (ppr ev $$ ppr ty1 $$ ppr ty2)
-       ; return Stop }
+           ContinueWith new_ev -> do { emitInsoluble (mkNonCanonical new_ev)
+                                     ; stopWith new_ev "Definitely not equal" }
+           Stop ev s -> pprPanic "canEqFailure" (s $$ ppr ev $$ ppr ty1 $$ ppr ty2) }
 \end{code}
 
 Note [Canonicalising type applications]
@@ -986,163 +630,56 @@ As this point we have an insoluble constraint, like Int~Bool.
    class constraint.
 
 
-Note [Canonical ordering for equality constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Implemented as (<+=) below:
-
-  - Type function applications always come before anything else.
-  - Variables always come before non-variables (other than type
-      function applications).
-
-Note that we don't need to unfold type synonyms on the RHS to check
-the ordering; that is, in the rules above it's OK to consider only
-whether something is *syntactically* a type function application or
-not.  To illustrate why this is OK, suppose we have an equality of the
-form 'tv ~ S a b c', where S is a type synonym which expands to a
-top-level application of the type function F, something like
-
-  type S a b c = F d e
-
-Then to canonicalize 'tv ~ S a b c' we flatten the RHS, and since S's
-expansion contains type function applications the flattener will do
-the expansion and then generate a skolem variable for the type
-function application, so we end up with something like this:
-
-  tv ~ x
-  F d e ~ x
-
-where x is the skolem variable.  This is one extra equation than
-absolutely necessary (we could have gotten away with just 'F d e ~ tv'
-if we had noticed that S expanded to a top-level type function
-application and flipped it around in the first place) but this way
-keeps the code simpler.
-
-Unlike the OutsideIn(X) draft of May 7, 2010, we do not care about the
-ordering of tv ~ tv constraints.  There are several reasons why we
-might:
-
-  (1) In order to be able to extract a substitution that doesn't
-      mention untouchable variables after we are done solving, we might
-      prefer to put touchable variables on the left. However, in and
-      of itself this isn't necessary; we can always re-orient equality
-      constraints at the end if necessary when extracting a substitution.
-
-  (2) To ensure termination we might think it necessary to put
-      variables in lexicographic order. However, this isn't actually
-      necessary as outlined below.
-
-While building up an inert set of canonical constraints, we maintain
-the invariant that the equality constraints in the inert set form an
-acyclic rewrite system when viewed as L-R rewrite rules.  Moreover,
-the given constraints form an idempotent substitution (i.e. none of
-the variables on the LHS occur in any of the RHS's, and type functions
-never show up in the RHS at all), the wanted constraints also form an
-idempotent substitution, and finally the LHS of a given constraint
-never shows up on the RHS of a wanted constraint.  There may, however,
-be a wanted LHS that shows up in a given RHS, since we do not rewrite
-given constraints with wanted constraints.
-
-Suppose we have an inert constraint set
-
-
-  tg_1 ~ xig_1         -- givens
-  tg_2 ~ xig_2
-  ...
-  tw_1 ~ xiw_1         -- wanteds
-  tw_2 ~ xiw_2
-  ...
-
-where each t_i can be either a type variable or a type function
-application. Now suppose we take a new canonical equality constraint,
-t' ~ xi' (note among other things this means t' does not occur in xi')
-and try to react it with the existing inert set.  We show by induction
-on the number of t_i which occur in t' ~ xi' that this process will
-terminate.
-
-There are several ways t' ~ xi' could react with an existing constraint:
-
-TODO: finish this proof.  The below was for the case where the entire
-inert set is an idempotent subustitution...
-
-(b) We could have t' = t_j for some j.  Then we obtain the new
-    equality xi_j ~ xi'; note that neither xi_j or xi' contain t_j.  We
-    now canonicalize the new equality, which may involve decomposing it
-    into several canonical equalities, and recurse on these.  However,
-    none of the new equalities will contain t_j, so they have fewer
-    occurrences of the t_i than the original equation.
-
-(a) We could have t_j occurring in xi' for some j, with t' /=
-    t_j. Then we substitute xi_j for t_j in xi' and continue.  However,
-    since none of the t_i occur in xi_j, we have decreased the
-    number of t_i that occur in xi', since we eliminated t_j and did not
-    introduce any new ones.
-
 \begin{code}
-canEqLeafFun :: CtEvidence 
-             -> SwapFlag
+canCFunEqCan :: CtEvidence 
              -> TyCon -> [TcType]   -- LHS
-             -> TcType -> TcType    -- RHS
-             -> TcS StopOrContinue
-canEqLeafFun ev swapped fn tys1 ty2 ps_ty2
-  | length tys1 > tyConArity fn
-  = -- Over-saturated type function on LHS: 
-    -- flatten LHS, leaving an AppTy, and go around again
-    do { (xi1, co1) <- flatten FMFullFlatten ev (mkTyConApp fn tys1)
-       ; mb <- rewriteEqEvidence ev swapped xi1 ps_ty2 
-                                 co1 (mkTcNomReflCo ps_ty2)
-       ; case mb of
-            Nothing     -> return Stop
-            Just new_ev -> can_eq_nc new_ev xi1 xi1 ty2 ps_ty2 }
-
-  | otherwise
-  = -- ev :: F tys1 ~ ty2,   if not swapped
-    -- ev :: ty2 ~ F tys1,   if swapped                                    
-    ASSERT( length tys1 == tyConArity fn )  
-        -- Type functions are never under-saturated
-        -- Previous equation checks for over-saturation
-    do { traceTcS "canEqLeafFun" $ pprEq (mkTyConApp fn tys1) ps_ty2
-
-            -- Flatten type function arguments
-            -- cos1 :: xis1 ~ tys1
-            -- co2  :: xi2 ~ ty2
-      ; (xis1,cos1) <- flattenMany FMFullFlatten ev tys1
-      ; (xi2, co2)  <- flatten     FMFullFlatten ev ps_ty2
-
-       ; let fam_head = mkTyConApp fn xis1
-             co1      = mkTcTyConAppCo Nominal fn cos1
-       ; mb <- rewriteEqEvidence ev swapped fam_head xi2 co1 co2
-
-       ; let k1 = typeKind fam_head
-             k2 = typeKind xi2
-       ; case mb of
-            Nothing     -> return Stop
-            Just new_ev | k1 `isSubKind` k2
-                        -- Establish CFunEqCan kind invariant
-                        -> continueWith (CFunEqCan { cc_ev = new_ev, cc_fun = fn
-                                                   , cc_tyargs = xis1, cc_rhs = xi2 })
-                        | otherwise
-                        -> checkKind new_ev fam_head k1 xi2 k2 }
+             -> 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 { let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll }
+       ; (tys', cos) <- flattenMany fmode tys
+                        -- cos :: tys' ~ tys
+       ; let lhs_co  = mkTcTyConAppCo Nominal fn cos
+                        -- :: F tys' ~ F tys
+             new_lhs = mkTyConApp fn tys'
+             fsk_ty  = mkTyVarTy fsk
+       ; mb_ev <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty
+                                    lhs_co (mkTcNomReflCo fsk_ty)
+       ; case mb_ev of {
+           Stop ev s        -> return (Stop ev s) ;
+           ContinueWith ev' ->
+
+    do { extendFlatCache fn tys' (ctEvCoercion ev', fsk)
+       ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn
+                                 , cc_tyargs = tys', cc_fsk = fsk }) } } }
 
 ---------------------
 canEqTyVar :: CtEvidence -> SwapFlag
-           -> TcTyVar 
+           -> TcTyVar
            -> TcType -> TcType
-           -> TcS StopOrContinue
+           -> TcS (StopOrContinue Ct)
 -- A TyVar on LHS, but so far un-zonked
 canEqTyVar ev swapped tv1 ty2 ps_ty2              -- ev :: tv ~ s2
   = do { traceTcS "canEqTyVar" (ppr tv1 $$ ppr ty2 $$ ppr swapped)
-       ; mb_yes <- flattenTyVarOuter FMFullFlatten ev tv1 
+       ; mb_yes <- flattenTyVarOuter ev tv1
        ; case mb_yes of
-           Right (ty1, co1) -> -- co1 :: ty1 ~ tv1
-                               do { mb <- rewriteEqEvidence ev swapped  ty1 ps_ty2
-                                                            co1 (mkTcNomReflCo ps_ty2)
-                                  ; traceTcS "canEqTyVar2" (vcat [ppr tv1, ppr ty2, ppr swapped, ppr ty1,
-                                                                  ppUnless (isDerived ev) (ppr co1)])
-                                  ; case mb of
-                                      Nothing     -> return Stop
-                                      Just new_ev -> can_eq_nc new_ev ty1 ty1 ty2 ps_ty2 }
-
-           Left tv1' -> do { (xi2, co2) <- flatten FMFullFlatten ev ps_ty2 -- co2 :: xi2 ~ ps_ty2
+           Right (ty1, co1, _) -- co1 :: ty1 ~ tv1
+                     -> do { mb <- rewriteEqEvidence ev swapped  ty1 ps_ty2
+                                                     co1 (mkTcNomReflCo ps_ty2)
+                           ; traceTcS "canEqTyVar2" (vcat [ppr tv1, ppr ty2, ppr swapped, ppr ty1,
+                                                           ppUnless (isDerived ev) (ppr co1)])
+                           ; case mb of
+                               Stop ev s           -> return (Stop ev s)
+                               ContinueWith new_ev -> can_eq_nc new_ev ty1 ty1 ty2 ps_ty2 }
+
+           Left tv1' -> do { let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True }
+                                 -- Flatten the RHS less vigorously, to avoid gratuitous flattening
+                                 -- True <=> xi2 should not itself be a type-function application
+                           ; (xi2, co2) <- flatten fmode ps_ty2 -- co2 :: xi2 ~ ps_ty2
                                            -- Use ps_ty2 to preserve type synonyms if poss
                            ; dflags <- getDynFlags
                            ; canEqTyVar2 dflags ev swapped tv1' xi2 co2 } }
@@ -1153,7 +690,7 @@ canEqTyVar2 :: DynFlags
             -> TcTyVar      -- olhs
             -> TcType       -- nrhs
             -> TcCoercion   -- nrhs ~ orhs
-            -> TcS StopOrContinue
+            -> TcS (StopOrContinue Ct)
 -- LHS is an inert type variable, 
 -- and RHS is fully rewritten, but with type synonyms
 -- preserved as much as possible
@@ -1171,87 +708,128 @@ canEqTyVar2 dflags ev swapped tv1 xi2 co2
        ; let k1 = tyVarKind tv1
              k2 = typeKind xi2'
        ; case mb of
-            Nothing     -> return Stop
-            Just new_ev | k2 `isSubKind` k1
-                        -- Establish CTyEqCan kind invariant
-                        -- Reorientation has done its best, but the kinds might
-                        -- simply be incompatible
-                        -> continueWith (CTyEqCan { cc_ev = new_ev
-                                                  , cc_tyvar  = tv1, cc_rhs = xi2' })
-                        | otherwise
-                        -> checkKind new_ev xi1 k1 xi2' k2 }
+            Stop ev s -> return (Stop ev s)
+            ContinueWith new_ev 
+                | k2 `isSubKind` k1
+                -- Establish CTyEqCan kind invariant
+                -- Reorientation has done its best, but the kinds might
+                -- simply be incompatible
+                -> continueWith (CTyEqCan { cc_ev = new_ev
+                                          , cc_tyvar  = tv1, cc_rhs = xi2' })
+                | otherwise
+                -> incompatibleKind new_ev xi1 k1 xi2' k2 }
 
   | otherwise  -- Occurs check error
   = do { mb <- rewriteEqEvidence ev swapped xi1 xi2 co1 co2
        ; case mb of
-           Nothing     -> return ()
-           Just new_ev -> emitInsoluble (mkNonCanonical new_ev)
-                          -- 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
-       ; return Stop }
+           Stop ev s           -> return (Stop ev s)
+           ContinueWith new_ev -> do { emitInsoluble (mkNonCanonical new_ev)
+              -- 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
+                                     ; stopWith new_ev "Occurs check" } }
   where
     xi1 = mkTyVarTy tv1
     co1 = mkTcNomReflCo xi1
 
 
-canEqTyVarTyVar :: CtEvidence       -- tv1 ~ orhs (or orhs ~ tv1, if swapped)
+
+canEqTyVarTyVar :: CtEvidence           -- tv1 ~ orhs (or orhs ~ tv1, if swapped)
                 -> SwapFlag
-                -> TyVar -> TyVar   -- tv2, tv2
-                -> TcCoercion       -- tv2 ~ orhs
-                -> TcS StopOrContinue
+                -> TcTyVar -> TcTyVar   -- tv2, tv2
+                -> TcCoercion           -- tv2 ~ orhs
+                -> TcS (StopOrContinue Ct)
 -- Both LHS and RHS rewrote to a type variable,
+-- If swapped = NotSwapped, then
+--     rw_orhs = tv1, rw_olhs = orhs
+--     rw_nlhs = tv2, rw_nrhs = xi1
+-- See Note [Canonical orientation for tyvar/tyvar equality constraints]
 canEqTyVarTyVar ev swapped tv1 tv2 co2
   | tv1 == tv2
   = do { when (isWanted ev) $
          ASSERT( tcCoercionRole co2 == Nominal )
          setEvBind (ctev_evar ev) (EvCoercion (maybeSym swapped co2))
-       ; return Stop }  
-
-  | reorient_me  -- See note [Canonical ordering for equality constraints].
-                 -- True => the kinds are compatible, 
-                 --         so no need for further sub-kind check
-                 -- If swapped = NotSwapped, then
-                 --     rw_orhs = tv1, rw_olhs = orhs
-                 --     rw_nlhs = tv2, rw_nrhs = xi1
-  = do { mb <- rewriteEqEvidence ev (flipSwap swapped)  xi2 xi1
-                                 co2 (mkTcNomReflCo xi1)
-       ; case mb of
-           Nothing     -> return Stop
-           Just new_ev -> continueWith (CTyEqCan { cc_ev = new_ev
-                                                 , cc_tyvar  = tv2, cc_rhs = xi1 }) }
-
-  | otherwise
-  = do { mb <- rewriteEqEvidence ev swapped xi1 xi2 
-                                 (mkTcNomReflCo xi1) co2
-       ; case mb of
-           Nothing     -> return Stop
-           Just new_ev | k2 `isSubKind` k1
-                       -> continueWith (CTyEqCan { cc_ev = new_ev
-                                                 , cc_tyvar = tv1, cc_rhs = xi2 })
-                       | otherwise
-                       -> checkKind new_ev xi1 k1 xi2 k2 } 
+       ; stopWith ev "Equal tyvars" }
+
+  | incompat_kind   = incompat
+  | isFmvTyVar tv1  = do_fmv swapped            tv1 xi1 xi2 co1 co2
+  | isFmvTyVar tv2  = do_fmv (flipSwap swapped) tv2 xi2 xi1 co2 co1
+  | same_kind       = if swap_over then do_swap else no_swap
+  | k1_sub_k2       = do_swap   -- Note [Kind orientation for CTyEqCan]
+  | otherwise       = no_swap   -- k2_sub_k1
   where
-    reorient_me 
-      | k1 `tcEqKind` k2    = tv2 `better_than` tv1
-      | k1 `isSubKind` k2   = True  -- Note [Kind orientation for CTyEqCan]
-      | otherwise           = False -- in TcRnTypes
-
     xi1 = mkTyVarTy tv1
     xi2 = mkTyVarTy tv2
     k1  = tyVarKind tv1
     k2  = tyVarKind tv2
-
-    tv2 `better_than` tv1
-      | isMetaTyVar tv1     = False   -- Never swap a meta-tyvar
-      | isFlatSkolTyVar tv1 = isMetaTyVar tv2
-      | otherwise           = isMetaTyVar tv2 || isFlatSkolTyVar tv2
-                            -- Note [Eliminate flat-skols]
-
-checkKind :: CtEvidence         -- t1~t2
-          -> TcType -> TcKind
-          -> TcType -> TcKind   -- s1~s2, flattened and zonked
-          -> TcS StopOrContinue
+    co1 = mkTcNomReflCo xi1
+    k1_sub_k2     = k1 `isSubKind` k2
+    k2_sub_k1     = k2 `isSubKind` k1
+    same_kind     = k1_sub_k2 && k2_sub_k1
+    incompat_kind = not (k1_sub_k2 || k2_sub_k1)
+
+    no_swap = canon_eq swapped            tv1 xi1 xi2 co1 co2
+    do_swap = canon_eq (flipSwap swapped) tv2 xi2 xi1 co2 co1
+
+    canon_eq swapped tv1 xi1 xi2 co1 co2
+        -- ev  : tv1 ~ orhs  (not swapped) or   orhs ~ tv1   (swapped)
+        -- co1 : xi1 ~ tv1
+        -- co2 : xi2 ~ tv2
+      = do { mb <- rewriteEqEvidence ev swapped xi1 xi2 co1 co2
+           ; let mk_ct ev' = CTyEqCan { cc_ev = ev', cc_tyvar = tv1, cc_rhs = xi2 }
+           ; return (fmap mk_ct mb) }
+
+    -- See Note [Orient equalities with flatten-meta-vars on the left] in TcFlatten
+    do_fmv swapped tv1 xi1 xi2 co1 co2
+      | same_kind
+      = canon_eq swapped tv1 xi1 xi2 co1 co2
+      | otherwise  -- Presumably tv1 `subKind` tv2, which is the wrong way round
+      = ASSERT2( k1_sub_k2, ppr tv1 $$ ppr tv2 )
+        ASSERT2( isWanted ev, ppr ev )  -- Only wanteds have flatten meta-vars
+        do { tv_ty <- newFlexiTcSTy (tyVarKind tv1)
+           ; new_ev <- newWantedEvVarNC (ctEvLoc ev) (mkTcEqPred tv_ty xi2)
+           ; emitWorkNC [new_ev]
+           ; canon_eq swapped tv1 xi1 tv_ty co1 (ctEvCoercion new_ev `mkTcTransCo` co2) }
+
+    incompat
+      = do { mb <- rewriteEqEvidence ev swapped xi1 xi2 (mkTcNomReflCo xi1) co2
+           ; case mb of
+               Stop ev s        -> return (Stop ev s)
+               ContinueWith ev' -> incompatibleKind ev' xi1 k1 xi2 k2 }
+
+    swap_over
+      -- If tv1 is touchable, swap only if tv2 is also
+      -- touchable and it's strictly better to update the latter
+      -- But see Note [Avoid unnecessary swaps]
+      | Just lvl1 <- metaTyVarUntouchables_maybe tv1
+      = case metaTyVarUntouchables_maybe tv2 of
+          Nothing   -> False
+          Just lvl2 | lvl2 `strictlyDeeperThan` lvl1 -> True
+                    | lvl1 `strictlyDeeperThan` lvl2 -> False
+                    | otherwise                      -> nicer_to_update_tv2
+
+      -- So tv1 is not a meta tyvar
+      -- If only one is a meta tyvar, put it on the left
+      -- This is not because it'll be solved; but becuase
+      -- the floating step looks for meta tyvars on the left
+      | isMetaTyVar tv2 = True
+
+      -- So neither is a meta tyvar
+
+      -- If only one is a flatten tyvar, put it on the left
+      -- See Note [Eliminate flat-skols]
+      | not (isFlattenTyVar tv1), isFlattenTyVar tv2 = True
+
+      | otherwise = False
+
+    nicer_to_update_tv2
+      =  (isSigTyVar tv1                 && not (isSigTyVar tv2))
+      || (isSystemName (Var.varName tv2) && not (isSystemName (Var.varName tv1)))
+
+incompatibleKind :: CtEvidence         -- t1~t2
+                 -> TcType -> TcKind
+                 -> TcType -> TcKind   -- s1~s2, flattened and zonked
+                 -> TcS (StopOrContinue Ct)
 -- LHS and RHS have incompatible kinds, so emit an "irreducible" constraint
 --       CIrredEvCan (NOT CTyEqCan or CFunEqCan)
 -- for the type equality; and continue with the kind equality constraint.
@@ -1260,23 +838,66 @@ checkKind :: CtEvidence         -- t1~t2
 --
 -- See Note [Equalities with incompatible kinds]
 
-checkKind new_ev s1 k1 s2 k2   -- See Note [Equalities with incompatible kinds]
+incompatibleKind new_ev s1 k1 s2 k2   -- See Note [Equalities with incompatible kinds]
   = ASSERT( isKind k1 && isKind k2 )
     do { traceTcS "canEqLeaf: incompatible kinds" (vcat [ppr k1, ppr k2])
 
          -- Create a derived kind-equality, and solve it
-       ; mw <- newDerived kind_co_loc (mkTcEqPred k1 k2)
-       ; case mw of
-           Nothing  -> return ()
-           Just kev -> emitWorkNC [kev]
+       ; emitNewDerived kind_co_loc (mkTcEqPred k1 k2)
 
          -- Put the not-currently-soluble thing into the inert set
        ; continueWith (CIrredEvCan { cc_ev = new_ev }) }
   where
-    loc = ctev_loc new_ev
+    loc = ctEvLoc new_ev
     kind_co_loc = setCtLocOrigin loc (KindEqOrigin s1 s2 (ctLocOrigin loc))
 \end{code}
 
+Note [Canonical orientation for tyvar/tyvar equality constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have a ~ b where both 'a' and 'b' are TcTyVars, which way
+round should be oriented in the CTyEqCan?  The rules, implemented by
+canEqTyVarTyVar, are these
+
+ * If either is a flatten-meta-variables, it goes on the left.
+
+ * If one is a strict sub-kind of the other e.g.
+       (alpha::?) ~ (beta::*)
+   orient them so RHS is a subkind of LHS.  That way we will replace
+   'a' with 'b', correctly narrowing the kind.
+   This establishes the subkind invariant of CTyEqCan.
+
+ * Put a meta-tyvar on the left if possible
+       alpha[3] ~ r
+
+ * If both are meta-tyvars, put the more touchable one (deepest level
+   number) on the left, so there is the best chance of unifying it
+        alpha[3] ~ beta[2]
+
+ * If both are meta-tyvars and both at the same level, put a SigTv
+   on the right if possible
+        alpha[2] ~ beta[2](sig-tv)
+   That way, when we unify alpha := beta, we don't lose the SigTv flag.
+
+ * Put a meta-tv with a System Name on the left if possible so it
+   gets eliminated (improves error messages)
+
+ * If one is a flatten-skolem, put it on the left so that it is
+   substituted out  Note [Elminate flat-skols]
+        fsk ~ a
+
+Note [Avoid unnecessary swaps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we swap without actually improving matters, we can get an infnite loop.
+Consider
+    work item:  a ~ b
+   inert item:  b ~ c
+We canonicalise the work-time to (a ~ c).  If we then swap it before
+aeding to the inert set, we'll add (c ~ a), and therefore kick out the
+inert guy, so we get
+   new work item:  b ~ c
+   inert item:     c ~ a
+And now the cycle just repeats
+
 Note [Eliminate flat-skols]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we have  [G] Num (F [a])
diff --git a/compiler/typecheck/TcFlatten.lhs b/compiler/typecheck/TcFlatten.lhs
new file mode 100644
index 0000000000..02783a9f08
--- /dev/null
+++ b/compiler/typecheck/TcFlatten.lhs
@@ -0,0 +1,1147 @@
+\begin{code}
+{-# LANGUAGE CPP #-}
+
+module TcFlatten(
+   FlattenEnv(..), FlattenMode(..),
+   flatten, flattenMany, flattenFamApp, flattenTyVarOuter,
+   unflatten,
+   eqCanRewrite, canRewriteOrSame
+ ) where
+
+#include "HsVersions.h"
+
+import TcRnTypes
+import TcType
+import Type
+import TcEvidence
+import TyCon
+import TypeRep
+import Kind( isSubKind )
+import Var
+import VarEnv
+import Outputable
+import VarSet
+import TcSMonad as TcS
+import DynFlags( DynFlags )
+
+import Util
+import Bag
+import FastString
+import Control.Monad( when )
+\end{code}
+
+
+Note [The flattening story]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* A CFunEqCan is either of form
+     [G] <F xis> : F xis ~ fsk   -- fsk is a FlatSkol
+     [W]       x : F xis ~ fmv   -- fmv is a unification variable,
+                                 -- but untouchable,
+                                 -- with MetaInfo = FlatMetaTv
+  where
+     x is the witness variable
+     fsk/fmv is a flatten skolem
+     xis are function-free
+  CFunEqCans are always [Wanted], or [Given], never [Derived]
+
+  fmv untouchable just means that in a CTyVarEq, say,
+       fmv ~ Int
+  we do NOT unify fmv.
+
+* KEY INSIGHTS:
+
+   - A given flatten-skolem, fsk, is known a-priori to be equal to
+     F xis (the LHS), with <F xis> evidence
+
+   - A unification flatten-skolem, fmv, stands for the as-yet-unknown
+     type to which (F xis) will eventually reduce
+
+* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2
+                       then xis1 /= xis2
+  i.e. at most one CFunEqCan with a particular LHS
+
+* Each canonical CFunEqCan x : F xis ~ fsk/fmv has its own
+  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.
+
+* Function applications can occur in the RHS of a CTyEqCan.  No reason
+  not allow this, and it reduces the amount of flattening that must occur.
+
+* 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
+
+* Unification flatten-skolems, fmv, ONLY get unified when either
+    a) The CFunEqCan takes a step, using an axiom
+    b) During un-flattening
+  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!)
+
+* [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.
+
+* [Firing rule: wanteds]
+    (work item) [W] x : F tys ~ fmv
+    instantiate axiom: ax_co : F tys ~ rhs
+
+   Dischard fmv:
+      fmv := alpha
+      x := ax_co ; sym x2
+      [W] x2 : alpha ~ rhs  (Non-canonical)
+   discharging the work item. This is the way that fmv's get
+   unified; even though they are "untouchable".
+
+   NB: this deals with the case where fmv appears in xi, which can
+   happen; it just happens through the non-canonical stuff
+
+   Possible short cut (shortCutReduction) if rhs = G rhs_tys,
+   where G is a type function.  Then
+      - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis)
+      - Add G rhs_xis ~ fmv to flat cache
+      - New wanted [W] x2 : G rhs_xis ~ fmv
+      - Discharge x := co ; G cos ; x2
+
+* [Firing rule: givens]
+    (work item) [G] g : F tys ~ fsk
+    instantiate axiom: co : F tys ~ rhs
+
+   Now add non-canonical (since rhs is not flat)
+      [G] (sym g ; co) : fsk ~ rhs
+
+   Short cut (shortCutReduction) for when rhs = G rhs_tys and G is a type function
+      [G] (co ; g) : G tys ~ fsk
+   But need to flatten tys:  flat_cos : tys ~ flat_tys
+      [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk
+
+
+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 ~ Boo)l 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
+       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 [Orient equalities with flatten-meta-vars on the left]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This example comes from IndTypesPerfMerge
+
+From the ambiguity check for
+  f :: (F a ~ a) => a
+we get:
+      [G] F a ~ a
+      [W] F alpha ~ alpha, alpha ~ a
+
+    From Givens we get
+      [G] F a ~ fsk, fsk ~ a
+
+    Now if we flatten we get
+      [W] alpha ~ fmv, F alpha ~ fmv, alpha ~ a
+
+    Now, processing the first one first, choosing alpha := fmv
+      [W] F fmv ~ fmv, fmv ~ a
+
+    And now we are stuck.  We must either *unify* fmv := a, or
+    use the fmv ~ a to rewrite F fmv ~ fmv, so we can make it
+    meet up with the given F a ~ blah.
+
+Solution: always put fmvs on the left, so we get
+      [W] fmv ~ alpha, F alpha ~ fmv, alpha ~ a
+  The point is that fmvs are very uninformative, so doing alpha := fmv
+  is a bad idea.  We want to use other constraints on alpha first.
+
+
+Note [Derived constraints from wanted CTyEqCans]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Is this type ambiguous:  (Foo e ~ Maybe e) => Foo e
+ (indexed-types/should_fail/T4093a)
+
+ [G] Foo e ~ Maybe e
+ [W] Foo e ~ Foo ee      -- ee is a unification variable
+ [W] Foo ee ~ Maybe ee)
+---
+ [G] Foo e ~ fsk
+ [G] fsk ~ Maybe e
+
+ [W] Foo e ~ fmv1
+ [W] Foo ee ~ fmv2
+ [W] fmv1 ~ fmv2
+ [W] fmv2 ~ Maybe ee
+
+--->   fmv1 := fsk  by matching LHSs
+ [W] Foo ee ~ fmv2
+ [W] fsk ~ fmv2
+ [W] fmv2 ~ Maybe ee
+
+--->
+ [W] Foo ee ~ fmv2
+ [W] fmv2 ~ Maybe e
+ [W] fmv2 ~ Maybe ee
+
+Now maybe we shuld get [D] e ~ ee, and then we'd solve it entirely.
+But if in a smilar situation we got [D] Int ~ Bool we'd be back
+to complaining about wanted/wanted interactions.  Maybe this arises
+also for fundeps?
+
+Here's another example:
+  f :: [a] -> [b] -> blah
+  f (e1 :: F Int) (e2 :: F Int)
+
+  we get
+     F Int ~ fmv
+     fmv ~ [alpha]
+     fmv ~ [beta]
+
+  We want: alpha := beta (which might unlock something else).  If we
+  generated [D] [alpha] ~ [beta] we'd be good here.
+
+Current story: we don't generate these derived constraints.  We could, but
+we'd want to make them very weak, so we didn't get the Int~Bool complaint.
+
+
+%************************************************************************
+%*                                                                      *
+%*                  Other notes (Oct 14)
+      I have not revisted these, but I didn't want to discard them
+%*                                                                      *
+%************************************************************************
+
+
+Try: rewrite wanted with wanted only for fmvs (not all meta-tyvars)
+
+But:   fmv ~ alpha[0]
+       alpha[0] ~ fmv’
+Now we don’t see that fmv ~ fmv’, which is a problem for injectivity detection.
+
+Conclusion: rewrite wanteds with wanted for all untouchables.
+
+skol ~ untch, must re-orieint to untch ~ skol, so that we can use it to rewrite.
+
+
+
+%************************************************************************
+%*                                                                      *
+%*                  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 unificaiton 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.
+
+--------------------------
+Trac #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
+
+
+%************************************************************************
+%*                                                                      *
+%*           The main flattening functions
+%*                                                                      *
+%************************************************************************
+
+Note [Flattening]
+~~~~~~~~~~~~~~~~~~~~
+  flatten ty  ==>   (xi, cc)
+    where
+      xi has no type functions, unless they appear under ForAlls
+
+      cc = Auxiliary given (equality) constraints constraining
+           the fresh type variables in xi.  Evidence for these
+           is always the identity coercion, because internally the
+           fresh flattening skolem variables are actually identified
+           with the types they have been generated to stand in for.
+
+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.
+
+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,
+it expands the synonym and proceeds; if not, it simply returns the
+unexpanded synonym.
+
+\begin{code}
+data FlattenEnv
+  = FE { fe_mode :: FlattenMode
+       , fe_ev   :: CtEvidence }
+
+data FlattenMode  -- Postcondition for all three: inert wrt the type substitution
+  = FM_FlattenAll          -- Postcondition: function-free
+
+  | FM_Avoid TcTyVar Bool  -- 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])
+
+  | FM_SubstOnly           -- See Note [Flattening under a forall]
+\end{code}
+
+\begin{code}
+-- Flatten a bunch of types all at once.
+flattenMany :: FlattenEnv -> [Type] -> TcS ([Xi], [TcCoercion])
+-- Coercions :: Xi ~ Type
+-- Returns True iff (no flattening happened)
+-- NB: The EvVar inside the 'fe_ev :: CtEvidence' is unused,
+--     we merely want (a) Given/Solved/Derived/Wanted info
+--                    (b) the GivenLoc/WantedLoc for when we create new evidence
+flattenMany fmode tys
+  = -- pprTrace "flattenMany" empty $
+    go tys
+  where go []       = return ([],[])
+        go (ty:tys) = do { (xi,co)    <- flatten fmode ty
+                         ; (xis,cos)  <- go tys
+                         ; return (xi:xis,co:cos) }
+
+flatten :: FlattenEnv -> TcType -> TcS (Xi, TcCoercion)
+-- Flatten a type to get rid of type function applications, returning
+-- the new type-function-free type, and a collection of new equality
+-- constraints.  See Note [Flattening] for more detail.
+--
+-- Postcondition: Coercion :: Xi ~ TcType
+
+flatten _ xi@(LitTy {}) = return (xi, mkTcNomReflCo xi)
+
+flatten fmode (TyVarTy tv)
+  = flattenTyVar fmode tv
+
+flatten fmode (AppTy ty1 ty2)
+  = do { (xi1,co1) <- flatten fmode ty1
+       ; (xi2,co2) <- flatten fmode ty2
+       ; traceTcS "flatten/appty" (ppr ty1 $$ ppr ty2 $$ ppr xi1 $$ ppr co1 $$ ppr xi2 $$ ppr co2)
+       ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) }
+
+flatten fmode (FunTy ty1 ty2)
+  = do { (xi1,co1) <- flatten fmode ty1
+       ; (xi2,co2) <- flatten fmode ty2
+       ; return (mkFunTy xi1 xi2, mkTcFunCo Nominal co1 co2) }
+
+flatten fmode (TyConApp tc tys)
+
+  -- Expand type synonyms that mention type families 
+  -- on the RHS; see Note [Flattening synonyms]
+  | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
+  , let expanded_ty = mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys'
+  = case fe_mode fmode of
+      FM_FlattenAll | any isSynFamilyTyCon (tyConsOfType rhs)
+                   -> flatten fmode expanded_ty
+                    | otherwise
+                   -> flattenTyConApp fmode tc tys
+      _ -> flattenTyConApp fmode 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.
+  | isSynFamilyTyCon tc
+  = flattenFamApp fmode tc tys
+
+  -- For * a normal data type application
+  --     * data family application
+  -- we just recursively flatten the arguments.
+  | otherwise  -- Switch off the flat_top bit in FM_Avoid
+  , let fmode' = case fmode of
+                   FE { fe_mode = FM_Avoid tv _ }
+                     -> fmode { fe_mode = FM_Avoid tv False }
+                   _ -> fmode
+  = flattenTyConApp fmode' tc tys
+
+flatten fmode ty@(ForAllTy {})
+-- We allow for-alls when, but only when, no type function
+-- applications inside the forall involve the bound type variables.
+  = do { let (tvs, rho) = splitForAllTys ty
+       ; (rho', co) <- flatten (fmode { fe_mode = FM_SubstOnly }) rho
+                         -- Substitute only under a forall
+                         -- See Note [Flattening under a forall]
+       ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) }
+
+flattenTyConApp :: FlattenEnv -> TyCon -> [TcType] -> TcS (Xi, TcCoercion)
+flattenTyConApp fmode tc tys
+  = do { (xis, cos) <- flattenMany fmode tys
+       ; return (mkTyConApp tc xis, mkTcTyConAppCo Nominal tc cos) }
+\end{code}
+
+Note [Flattening synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+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 TcEvidence.
+
+But (Trac #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.
+
+
+Note [Flattening under a forall]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Under a forall, we
+  (a) MUST apply the inert substitution
+  (b) MUST NOT flatten type family applications
+Hence FMSubstOnly.
+
+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!
+
+%************************************************************************
+%*                                                                      *
+             Flattening a type-family application
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+flattenFamApp, flattenExactFamApp, flattenExactFamApp_fully
+  :: FlattenEnv -> TyCon -> [TcType] -> TcS (Xi, TcCoercion)
+  --   flattenFamApp            can be over-saturated
+  --   flattenExactFamApp       is exactly saturated
+  --   flattenExactFamApp_fully lifts out the application to top level
+  -- Postcondition: Coercion :: Xi ~ F tys
+flattenFamApp fmode tc tys  -- Can be over-saturated
+    = ASSERT( tyConArity tc <= length tys )  -- 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) <- flattenExactFamApp fmode tc tys1
+               -- co1 :: xi1 ~ F tys1
+         ; (xis_rest, cos_rest) <- flattenMany fmode tys_rest
+               -- cos_res :: xis_rest ~ tys_rest
+         ; return ( mkAppTys xi1 xis_rest   -- NB mkAppTys: rhs_xi might not be a type variable
+                                            --    cf Trac #5655
+                  , mkTcAppCos co1 cos_rest -- (rhs_xi :: F xis) ; (F cos :: F xis ~ F tys)
+                  ) }
+
+flattenExactFamApp fmode tc tys
+  = case fe_mode fmode of
+       FM_SubstOnly -> do { (xis, cos) <- flattenMany fmode tys
+                          ; return ( mkTyConApp tc xis
+                                   , mkTcTyConAppCo Nominal tc cos ) }
+
+       FM_Avoid tv flat_top -> do { (xis, cos) <- flattenMany fmode tys
+                                  ; if flat_top || tv `elemVarSet` tyVarsOfTypes xis
+                                    then flattenExactFamApp_fully fmode tc tys
+                                    else return ( mkTyConApp tc xis
+                                                , mkTcTyConAppCo Nominal tc cos ) }
+       FM_FlattenAll -> flattenExactFamApp_fully fmode tc tys
+
+flattenExactFamApp_fully fmode tc tys
+  = do { (xis, cos) <- flattenMany (fmode { fe_mode = FM_FlattenAll })tys
+       ; let ret_co = mkTcTyConAppCo Nominal tc cos
+              -- ret_co :: F xis ~ F tys
+             ctxt_ev = fe_ev fmode
+
+       ; mb_ct <- lookupFlatCache tc xis
+       ; case mb_ct of
+           Just (co, fsk)  -- co :: F xis ~ fsk
+             | isFskTyVar fsk || not (isGiven ctxt_ev)
+             ->  -- Usable hit in the flat-cache
+                 -- isFskTyVar checks for a "given" in the cache
+                do { traceTcS "flatten/flat-cache hit" $ (ppr tc <+> ppr xis $$ ppr fsk $$ ppr co)
+                   ; (fsk_xi, fsk_co) <- flattenTyVar fmode fsk
+                          -- The fsk may already have been unified, so flatten it
+                          -- fsk_co :: fsk_xi ~ fsk
+                   ; return (fsk_xi, fsk_co `mkTcTransCo` mkTcSymCo co `mkTcTransCo` ret_co) }
+                                    -- :: fsk_xi ~ F xis
+
+           _ -> do { let fam_ty = mkTyConApp tc xis
+                   ; (ev, fsk) <- newFlattenSkolem ctxt_ev fam_ty
+                   ; extendFlatCache tc xis (ctEvCoercion ev, fsk)
+
+                   -- 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 }
+                   ; updWorkListTcS (extendWorkListFunEq ct)
+
+                   ; traceTcS "flatten/flat-cache miss" $ (ppr fam_ty $$ ppr fsk $$ ppr ev)
+                   ; return (mkTyVarTy fsk, mkTcSymCo (ctEvCoercion ev) `mkTcTransCo` ret_co) } }
+\end{code}
+
+%************************************************************************
+%*                                                                      *
+             Flattening a type variable
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+flattenTyVar :: FlattenEnv -> TcTyVar -> TcS (Xi, TcCoercion)
+-- "Flattening" a type variable means to apply the substitution to it
+-- The substitution is actually the union of the substitution in the TyBinds
+-- for the unification variables that have been unified already with the inert
+-- equalities, see Note [Spontaneously solved in TyBinds] in TcInteract.
+--
+-- Postcondition: co : xi ~ tv
+flattenTyVar fmode tv
+  = do { mb_yes <- flattenTyVarOuter (fe_ev fmode) tv
+       ; case mb_yes of
+           Left tv' -> -- Done
+                       do { traceTcS "flattenTyVar1" (ppr tv $$ ppr (tyVarKind tv'))
+                          ; return (ty', mkTcNomReflCo ty') }
+                    where
+                       ty' = mkTyVarTy tv'
+
+           Right (ty1, co1, True)   -- No need to recurse
+                    -> do { traceTcS "flattenTyVar2" (ppr tv $$ ppr ty1)
+                          ; return (ty1, co1) }
+
+           Right (ty1, co1, False)  -- Recurse
+                    -> do { (ty2, co2) <- flatten fmode ty1
+                          ; traceTcS "flattenTyVar3" (ppr tv $$ ppr ty2)
+                          ; return (ty2, co2 `mkTcTransCo` co1) }
+       }
+
+flattenTyVarOuter, flattenTyVarFinal
+   :: CtEvidence -> TcTyVar
+   -> TcS (Either TyVar (TcType, TcCoercion, Bool))
+-- Look up the tyvar in
+--   a) the internal MetaTyVar box
+--   b) the tyvar binds
+--   c) the inerts
+-- Return (Left tv')                if it is not found, tv' has a properly zonked kind
+--        (Right (ty, co, is_flat)) if found, with co :: ty ~ tv;
+--                                  is_flat says if the result is guaranteed flattened
+
+flattenTyVarOuter ctxt_ev tv
+  | not (isTcTyVar tv)             -- Happens when flatten under a (forall a. ty)
+  = flattenTyVarFinal ctxt_ev tv   -- So ty contains refernces to the non-TcTyVar a
+  | otherwise
+  = do { mb_ty <- isFilledMetaTyVar_maybe tv
+       ; case mb_ty of {
+           Just ty -> do { traceTcS "Following filled tyvar" (ppr tv <+> equals <+> ppr ty)
+                         ; return (Right (ty, mkTcNomReflCo ty, False)) } ;
+           Nothing ->
+
+    -- Try in the inert equalities
+    -- See Note [Applying the inert substitution]
+    do { ieqs <- getInertEqs
+       ; case lookupVarEnv 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 } <- ct
+             , eqCanRewrite ctev ctxt_ev
+             ->  do { traceTcS "Following inert tyvar" (ppr tv <+> equals <+> ppr rhs_ty $$ ppr ctev)
+                    ; return (Right (rhs_ty, mkTcSymCo (ctEvCoercion ctev), True)) }
+                    -- NB: ct is Derived then (fe_ev fmode) must be also, hence
+                    -- we are not going to touch the returned coercion
+                    -- so ctEvCoercion is fine.
+
+           _other -> flattenTyVarFinal ctxt_ev tv
+    } } }
+
+flattenTyVarFinal ctxt_ev tv
+  = -- Done, but make sure the kind is zonked
+    do { let kind       = tyVarKind tv
+             kind_fmode = FE { fe_ev = ctxt_ev, fe_mode = FM_SubstOnly }
+       ; (new_knd, _kind_co) <- flatten kind_fmode kind
+       ; return (Left (setVarType tv new_knd)) }
+\end{code}
+
+Note [Applying the inert substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The inert CTyEqCans (a ~ ty), inert_eqs, can be treated as a
+substitution, and indeed flattenTyVarOuter applies it to the type
+being flattened.  It has the following properties:
+
+ * 'a' is not in fvs(ty)
+ * They are *inert*; that is the eqCanRewrite relation is everywhere false
+
+An example of such an inert substitution is:
+
+ [G] g1 : ta8 ~ ta4
+ [W] g2 : ta4 ~ a5Fj
+
+If you ignored the G/W, it would not be an idempotent, but we don't ignore
+it.  When rewriting a constraint
+    ev_work :: blah
+we only rewrite it with an inert constraint
+    ev_inert1 :: a ~ ty
+if
+    ev_inert1 `eqCanRewrite` ev_work
+
+This process stops in exactly one step; that is, the RHS 'ty' cannot be further
+rewritten by any other inert.  Why not?  If it could, we'd have
+    ev_inert1 :: a ~ ty[b]
+    ev_inert2 :: b ~ ty'
+and
+    ev_inert2 `canRewrite` ev_work
+But by the EqCanRewrite Property (see Note [eqCanRewrite]), that means
+that ev_inert2 `eqCanRewrite` ev_inert1; but that means that 'b' can't
+appear free in ev_inert1's RHS.
+
+When we *unify* a variable, which we write
+  alpha := ty
+we must be sure we aren't creating an infinite type.  But that comes
+from the CTyEqCan invariant that 'a' not in fvs(ty), plus the fact that
+an inert CTyEqCan is fully zonked wrt the current unification assignments.
+In effect they become Givens, implemented via the side-effected substitution.
+
+Note [An alternative story for the inert substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used (GHC 7.8) to have this story for the inert substitution inert_eqs
+
+ * 'a' is not in fvs(ty)
+ * They are *inert* in the weaker sense that there is no infinite chain of
+   (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc
+
+This means that flattening must be recursive, but it does allow
+  [G] a ~ [b]
+  [G] b ~ Maybe c
+
+This avoids "saturating" the Givens, which can save a modest amount of work.
+It is easy to implement, in TcInteract.kick_out, by only kicking out an inert
+only if (a) the work item can rewrite the inert AND
+        (b) the inert cannot rewrite the work item
+
+This is signifcantly harder to think about. It can save a LOT of work
+in occurs-check cases, but we don't care about them much.  Trac #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)
+
+    --->
+    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 pathalogical
+casee, so we don't care.
+
+
+\begin{code}
+eqCanRewrite :: CtEvidence -> CtEvidence -> Bool
+-- Very important function!
+-- See Note [eqCanRewrite]
+eqCanRewrite (CtGiven {})   _              = True
+eqCanRewrite (CtDerived {}) (CtDerived {}) = True  -- Derived can't solve wanted/given
+eqCanRewrite _ _ = False
+
+canRewriteOrSame :: CtEvidence -> CtEvidence -> Bool
+-- See Note [canRewriteOrSame]
+canRewriteOrSame (CtGiven {})   _              = True
+canRewriteOrSame (CtWanted {})  (CtWanted {})  = True
+canRewriteOrSame (CtWanted {})  (CtDerived {}) = True
+canRewriteOrSame (CtDerived {}) (CtDerived {}) = True
+canRewriteOrSame _ _ = False
+\end{code}
+
+Note [eqCanRewrite]
+~~~~~~~~~~~~~~~~~~~
+(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form
+tv ~ ty) can be used to rewrite ct2.
+
+The EqCanRewrite Property:
+  * For any a,b in {G,W,D}  if   a canRewrite b
+                            then a canRewrite a
+  This is what guarantees that canonicalisation will terminate.
+  See Note [Applying the inert substitution]
+
+At the moment we don't allow Wanteds to rewrite Wanteds, because that can give
+rise to very confusing type error messages.  A good example is Trac #8450.
+Here's another
+   f :: a -> Bool
+   f x = ( [x,'c'], [x,True] ) `seq` True
+Here we get
+  [W] a ~ Char
+  [W] a ~ Bool
+but we do not want to complain about Bool ~ Char!
+
+Note [canRewriteOrSame]
+~~~~~~~~~~~~~~~~~~~~~~~
+canRewriteOrSame is similar but
+ * returns True for Wanted/Wanted.
+ * works for all kinds of constraints, not just CTyEqCans
+See the call sites for explanations.
+
+%************************************************************************
+%*                                                                      *
+             Unflattening
+%*                                                                      *
+%************************************************************************
+
+An unflattening example:
+    [W] F a ~ alpha
+flattens to
+    [W] F a ~ fmv   (CFunEqCan)
+    [W] fmv ~ alpha (CTyEqCan)
+We must solve both!
+
+
+\begin{code}
+unflatten :: Cts -> Cts -> TcS Cts
+unflatten tv_eqs funeqs
+ = do { dflags   <- getDynFlags
+      ; untch    <- getUntouchables
+
+      ; traceTcS "Unflattening" $ braces $
+        vcat [ ptext (sLit "Funeqs =") <+> pprCts funeqs
+             , ptext (sLit "Tv eqs =") <+> pprCts tv_eqs ]
+
+         -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check
+         -- See Note [Unflatten using funeqs first]
+      ; funeqs <- foldrBagM (unflatten_funeq dflags) emptyCts funeqs
+      ; traceTcS "Unflattening 1" $ braces (pprCts funeqs)
+
+          -- Step 2: unify the irreds, if possible
+      ; tv_eqs  <- foldrBagM (unflatten_eq dflags untch) 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 irreds that look like ty ~ ty
+      ; tv_eqs <- foldrBagM 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 :: DynFlags -> Ct -> Cts -> TcS Cts
+    unflatten_funeq dflags ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis
+                                         , cc_fsk = fmv, cc_ev = ev }) rest
+      = do {   -- fmv should be a flatten meta-tv; we now fix its final
+               -- value, and then zonking will eliminate it
+             filled <- tryFill dflags fmv (mkTyConApp tc xis) ev
+           ; return (if filled then rest else 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 ::  DynFlags -> Untouchables -> Ct -> Cts -> TcS Cts
+    unflatten_eq dflags untch ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs }) rest
+      | isFmvTyVar tv
+      = do { lhs_elim <- tryFill dflags tv rhs ev
+           ; if lhs_elim then return rest else
+        do { rhs_elim <- try_fill dflags untch ev rhs (mkTyVarTy tv)
+           ; if rhs_elim then return rest else
+             return (ct `consCts` rest) } }
+
+      | otherwise
+      = return (ct `consCts` rest)
+
+    unflatten_eq _ _ ct _ = pprPanic "unflatten_irred" (ppr ct)
+
+    ----------------
+    finalise_eq :: Ct -> Cts -> TcS Cts
+    finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs }) rest
+      | isFmvTyVar tv
+      = do { ty1 <- zonkTcTyVar tv
+           ; ty2 <- zonkTcType rhs
+           ; let is_refl = ty1 `tcEqType` ty2
+           ; if is_refl then do { when (isWanted ev) $
+                                  setEvBind (ctEvId ev) (EvCoercion $ mkTcNomReflCo rhs)
+                                ; return rest }
+                        else return (mkNonCanonical ev `consCts` rest) }
+      | otherwise
+      = return (mkNonCanonical ev `consCts` rest)
+
+    finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct)
+
+    ----------------
+    try_fill dflags untch ev ty1 ty2
+      | Just tv1 <- tcGetTyVar_maybe ty1
+      , isTouchableOrFmv untch tv1
+      , typeKind ty1 `isSubKind` tyVarKind tv1
+      = tryFill dflags tv1 ty2 ev
+      | otherwise
+      = return False
+
+tryFill :: DynFlags -> TcTyVar -> TcType -> CtEvidence -> TcS Bool
+-- (tryFill tv rhs ev) sees if 'tv' is an un-filled MetaTv
+-- If so, and if tv does not appear in 'rhs', set tv := rhs
+-- bind the evidence (which should be a CtWanted) to Refl<rhs>
+-- and return True.  Otherwise return False
+tryFill dflags tv rhs ev
+  = ASSERT2( not (isGiven ev), ppr ev )
+    do { is_filled <- isFilledMetaTyVar tv
+       ; if is_filled then return False else
+    do { rhs' <- zonkTcType rhs
+       ; case occurCheckExpand dflags tv rhs' of
+           OC_OK rhs''    -- Normal case: fill the tyvar
+             -> do { when (isWanted ev) $
+                     setEvBind (ctEvId ev) (EvCoercion (mkTcNomReflCo rhs''))
+                   ; setWantedTyBind tv rhs''
+                   ; return True }
+
+           _ ->  -- Occurs check
+                 return False } }
+\end{code}
+
+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.
+
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 747eb91872..4884f1fd75 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -2,14 +2,15 @@
 {-# LANGUAGE CPP #-}
 
 module TcInteract (
-     solveInteractGiven,  -- Solves [EvVar],GivenLoc
-     solveInteract,       -- Solves Cts
+     solveFlatGivens,    -- Solves [EvVar],GivenLoc
+     solveFlatWanteds    -- Solves Cts
   ) where
 
 #include "HsVersions.h"
 
 import BasicTypes ()
 import TcCanonical
+import TcFlatten
 import VarSet
 import Type
 import Unify
@@ -38,8 +39,6 @@ import TcErrors
 import TcSMonad
 import Bag
 
-import Control.Monad ( foldM )
-import Data.Maybe ( catMaybes )
 import Data.List( partition )
 
 import VarEnv
@@ -81,47 +80,76 @@ 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 flat wanteds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We unflatten after solving the wc_flats of an implication, and before attempting
+to float. This means that
+
+ * The fsk/fmv flatten-skolems only survive during solveFlats.  We don't
+   need to worry about then 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: Trac #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 flat 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
+
+
 \begin{code}
-solveInteractGiven :: CtLoc -> [TcTyVar] -> [EvVar] -> TcS (Bool, [TcTyVar])
-solveInteractGiven loc old_fsks givens
+solveFlatGivens :: CtLoc -> [EvVar] -> TcS ()
+solveFlatGivens loc givens
   | null givens  -- Shortcut for common case
-  = return (True, old_fsks)
+  = return ()
   | otherwise
-  = do { implics1 <- solveInteract fsk_bag
-
-       ; (no_eqs, more_fsks, implics2) <- getGivenInfo (solveInteract given_bag)
-       ; MASSERT( isEmptyBag implics1 && isEmptyBag implics2 )
-           -- empty implics because we discard Given equalities between
-           -- foralls (see Note [Do not decompose given polytype equalities]
-           -- in TcCanonical), and those are the ones that can give
-           -- rise to new implications
-
-       ; return (no_eqs, more_fsks ++ old_fsks) }
+  = solveFlats (listToBag (map mk_given_ct givens))
   where
-    given_bag = listToBag [ mkNonCanonical $ CtGiven { ctev_evtm = EvId ev_id
-                                                     , ctev_pred = evVarPred ev_id
-                                                     , ctev_loc = loc }
-                          | ev_id <- givens ]
-
-    -- See Note [Given flatten-skolems] in TcSMonad
-    fsk_bag = listToBag [ mkNonCanonical $ CtGiven { ctev_evtm = EvCoercion (mkTcNomReflCo tv_ty)
-                                                   , ctev_pred = pred
-                                                   , ctev_loc = loc }
-                        | tv <- old_fsks
-                        , let FlatSkol fam_ty = tcTyVarDetails tv
-                              tv_ty = mkTyVarTy tv
-                              pred  = mkTcEqPred fam_ty tv_ty
-                        ]
+    mk_given_ct ev_id = mkNonCanonical (CtGiven { ctev_evtm = EvId ev_id
+                                                , ctev_pred = evVarPred ev_id
+                                                , ctev_loc  = loc })
+
+solveFlatWanteds :: Cts -> TcS WantedConstraints
+solveFlatWanteds wanteds
+  = do { solveFlats wanteds
+       ; unsolved_implics                  <- getWorkListImplics
+       ; (tv_eqs, fun_eqs, insols, others) <- getUnsolvedInerts
+       ; unflattened_eqs <- unflatten tv_eqs fun_eqs
+            -- See Note [Unflatten after solving the flat wanteds]
+
+       ; zonked <- zonkFlats (others `andCts` unflattened_eqs)
+            -- Postcondition is that the wl_flats are zonked
+       ; return (WC { wc_flat  = zonked
+                    , wc_insol = insols
+                    , wc_impl  = unsolved_implics }) }
 
 -- The main solver loop implements Note [Basic Simplifier Plan]
 ---------------------------------------------------------------
-solveInteract :: Cts -> TcS (Bag Implication)
+solveFlats :: Cts -> TcS ()
 -- Returns the final InertSet in TcS
 -- Has no effect on work-list or residual-iplications
-solveInteract cts
-  = {-# SCC "solveInteract" #-}
-    withWorkList cts $
+-- The constraints are initially examined in left-to-right order
+
+solveFlats cts
+  = {-# SCC "solveFlats" #-}
     do { dyn_flags <- getDynFlags
+       ; updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts)
        ; solve_loop (maxSubGoalDepth dyn_flags) }
   where
     solve_loop max_depth
@@ -136,7 +164,7 @@ solveInteract cts
                 -> do { runSolverPipeline thePipeline ct; solve_loop max_depth } }
 
 type WorkItem = Ct
-type SimplifierStage = WorkItem -> TcS StopOrContinue
+type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct)
 
 data SelectWorkItem
        = NoWorkRemaining      -- No more work left (effectively we're done!)
@@ -177,26 +205,27 @@ runSolverPipeline pipeline workItem
 
        ; final_is <- getTcSInerts
        ; case final_res of
-           Stop            -> do { traceTcS "End solver pipeline (discharged) }"
-                                       (ptext (sLit "inerts    = ") <+> ppr final_is)
+           Stop ev s       -> do { traceFireTcS ev s
+                                 ; traceTcS "End solver pipeline (discharged) }"
+                                       (ptext (sLit "inerts =") <+> ppr final_is)
                                  ; return () }
-           ContinueWith ct -> do { traceFireTcS ct (ptext (sLit "Kept as inert"))
+           ContinueWith ct -> do { traceFireTcS (ctEvidence ct) (ptext (sLit "Kept as inert"))
                                  ; traceTcS "End solver pipeline (not discharged) }" $
-                                       vcat [ ptext (sLit "final_item = ") <+> ppr ct
+                                       vcat [ ptext (sLit "final_item =") <+> ppr ct
                                             , pprTvBndrs (varSetElems $ tyVarsOfCt ct)
-                                            , ptext (sLit "inerts     = ") <+> ppr final_is]
+                                            , ptext (sLit "inerts     =") <+> ppr final_is]
                                  ; insertInertItemTcS ct }
        }
-  where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue -> TcS StopOrContinue
-        run_pipeline [] res = return res
-        run_pipeline _ Stop = return Stop
+  where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct 
+                     -> TcS (StopOrContinue Ct)
+        run_pipeline [] res        = return res
+        run_pipeline _ (Stop ev s) = return (Stop ev s)
         run_pipeline ((stg_name,stg):stgs) (ContinueWith ct)
           = do { traceTcS ("runStage " ++ stg_name ++ " {")
                           (text "workitem   = " <+> ppr ct)
                ; res <- stg ct
                ; traceTcS ("end stage " ++ stg_name ++ " }") empty
-               ; run_pipeline stgs res
-               }
+               ; run_pipeline stgs res }
 \end{code}
 
 Example 1:
@@ -266,27 +295,21 @@ or, equivalently,
 
 type StopNowFlag = Bool    -- True <=> stop after this interaction
 
-interactWithInertsStage :: WorkItem -> TcS StopOrContinue
+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.
 
 interactWithInertsStage wi
   = do { inerts <- getTcSInerts
        ; let ics = inert_cans inerts
-       ; (mb_ics', stop) <- case wi of
+       ; case wi of
              CTyEqCan    {} -> interactTyVarEq ics wi
              CFunEqCan   {} -> interactFunEq   ics wi
              CIrredEvCan {} -> interactIrred   ics wi
              CDictCan    {} -> interactDict    ics wi
-             _ -> pprPanic "interactWithInerts" (ppr wi)
+             _ -> pprPanic "interactWithInerts" (ppr wi) }
                 -- CHoleCan are put straight into inert_frozen, so never get here
                 -- CNonCanonical have been canonicalised
-       ; case mb_ics' of
-           Just ics' -> setTcSInerts (inerts { inert_cans = ics' })
-           Nothing   -> return ()
-       ; case stop of
-            True  -> return Stop
-            False -> return (ContinueWith wi) }
 \end{code}
 
 \begin{code}
@@ -336,7 +359,7 @@ solveOneFromTheOther ev_i ev_w
 -- we can rewrite them. We can never improve using this:
 -- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not
 -- mean that (ty1 ~ ty2)
-interactIrred :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag)
+interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct)
 
 interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w })
   | let pred = ctEvPred ev_w
@@ -346,16 +369,19 @@ interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w })
   , let ctev_i = ctEvidence ct_i
   = ASSERT( null rest )
     do { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w
-       ; let inerts' = case inert_effect of
-                          IRKeep    -> Nothing
-                          IRDelete  -> Just (inerts { inert_irreds = others })
-                          IRReplace -> Just (inerts { inert_irreds = extendCts others workItem })
-       ; when stop_now $ traceFireTcS workItem $
-         ptext (sLit "Irred equal") <+> parens (ppr inert_effect)
-       ; return (inerts', stop_now) }
+       ; case inert_effect of
+            IRKeep    -> return ()
+            IRDelete  -> updInertIrreds (\_ -> others)
+            IRReplace -> updInertIrreds (\_ -> others `snocCts` workItem)
+                         -- These const upd's assume that solveOneFromTheOther
+                         -- has no side effects on InertCans
+       ; if stop_now then
+            return (Stop ev_w (ptext (sLit "Irred equal") <+> parens (ppr inert_effect)))
+       ; else
+            continueWith workItem }
 
   | otherwise
-  = return (Nothing, False)
+  = continueWith workItem
 
 interactIrred _ wi = pprPanic "interactIrred" (ppr wi)
 \end{code}
@@ -367,19 +393,19 @@ interactIrred _ wi = pprPanic "interactIrred" (ppr wi)
 *********************************************************************************
 
 \begin{code}
-interactDict :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag)
+interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)
 interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })
-  | let dicts = inert_dicts inerts
-  , Just ct_i <- findDict (inert_dicts inerts) cls tys
+  | Just ct_i <- findDict (inert_dicts inerts) cls tys
   , let ctev_i = ctEvidence ct_i
   = do { (inert_effect, stop_now) <- solveOneFromTheOther ctev_i ev_w
-       ; let inerts' = case inert_effect of
-                          IRKeep    -> Nothing
-                          IRDelete  -> Just (inerts { inert_dicts = delDict dicts cls tys })
-                          IRReplace -> Just (inerts { inert_dicts = addDict dicts cls tys workItem })
-       ; when stop_now $ traceFireTcS workItem $
-         ptext (sLit "Dict equal") <+> parens (ppr inert_effect)
-       ; return (inerts', stop_now) }
+       ; case inert_effect of
+           IRKeep    -> return ()
+           IRDelete  -> updInertDicts $ \ ds -> delDict ds cls tys
+           IRReplace -> updInertDicts $ \ ds -> addDict ds cls tys workItem
+       ; if stop_now then
+            return (Stop ev_w (ptext (sLit "Dict equal") <+> parens (ppr inert_effect)))
+         else 
+            continueWith workItem }
 
   | cls `hasKey` ipClassNameKey
   , isGiven ev_w
@@ -389,16 +415,17 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs
   = do { mapBagM_ (addFunDepWork workItem) (findDictsByClass (inert_dicts inerts) cls)
                -- Standard thing: create derived fds and keep on going. Importantly we don't
                -- throw workitem back in the worklist because this can cause loops (see #5236)
-       ; return (Nothing, False) }
+       ; continueWith workItem  }
 
 interactDict _ wi = pprPanic "interactDict" (ppr wi)
 
-interactGivenIP :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag)
+interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct)
 -- Work item is Given (?x:ty)
 -- See Note [Shadowing of Implicit Parameters]
-interactGivenIP inerts workItem@(CDictCan { cc_class = cls, cc_tyargs = tys@(ip_str:_) })
-  = do { traceFireTcS workItem $ ptext (sLit "Given IP")
-       ; return (Just (inerts { inert_dicts = addDict filtered_dicts cls tys workItem }), True) }
+interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls
+                                          , cc_tyargs = tys@(ip_str:_) })
+  = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem }
+       ; stopWith ev "Given IP" }
   where
     dicts           = inert_dicts inerts
     ip_dicts        = findDictsByClass dicts cls
@@ -417,21 +444,13 @@ addFunDepWork work_ct inert_ct
   = do {  let fd_eqns :: [Equation CtLoc]
               fd_eqns = [ eqn { fd_loc = derived_loc }
                         | eqn <- improveFromAnother inert_pred work_pred ]
-       ; fd_work <- rewriteWithFunDeps fd_eqns
+       ; rewriteWithFunDeps fd_eqns
                 -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok
                 -- NB: We do create FDs for given to report insoluble equations that arise
                 -- from pairs of Givens, and also because of floating when we approximate
                 -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs
                 -- Also see Note [When improvement happens]
-
-       ; traceTcS "addFuNDepWork"
-                  (vcat [ text "inertItem =" <+> ppr inert_ct
-                        , text "workItem  =" <+> ppr work_ct
-                        , text "fundeps =" <+> ppr fd_work ])
-
-       ; case fd_work of
-           [] -> return ()
-           _  -> updWorkListTcS (extendWorkListEqs fd_work)    }
+    }
   where
     work_pred  = ctPred work_ct
     inert_pred = ctPred inert_ct
@@ -499,93 +518,72 @@ I can think of two ways to fix this:
 *********************************************************************************
 
 \begin{code}
-interactFunEq :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag)
+interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
+-- Try interacting the work item with the inert set
 interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc
-                                         , cc_tyargs = args, cc_rhs = rhs })
-  | (CFunEqCan { cc_ev = ev_i, cc_rhs = rhs_i } : _) <- matching_inerts
-  , ev_i `canRewrite` ev
-  = do { traceTcS "interact with inerts: FunEq/FunEq" $
-         vcat [ text "workItem =" <+> ppr workItem
-              , text "inertItem=" <+> ppr ev_i ]
-       ; solveFunEq ev_i rhs_i ev rhs
-       ; return (Nothing, True) }
-
-  | (ev_i : _) <- [ ev_i | CFunEqCan { cc_ev = ev_i, cc_rhs = rhs_i } <- matching_inerts
-                         , rhs_i `tcEqType` rhs    -- Duplicates
-                         , ev_i `canRewriteOrSame` ev ]
-  = do { when (isWanted ev) (setEvBind (ctev_evar ev) (ctEvTerm ev_i))
-       ; return (Nothing, True) }
-
-  | eq_is@(eq_i : _) <- matching_inerts
-  , ev `canRewrite` ctEvidence eq_i   -- This is unusual
-  = do { let solve (CFunEqCan { cc_ev = ev_i, cc_rhs = rhs_i })
-                      = solveFunEq ev rhs ev_i rhs_i
-             solve ct = pprPanic "interactFunEq" (ppr ct)
-       ; mapM_ solve eq_is
-       ; return (Just (inerts { inert_funeqs = replaceFunEqs funeqs tc args workItem }), True) }
-
-  | (CFunEqCan { cc_rhs = rhs_i } : _) <- matching_inerts
-  = -- We have  F ty ~ r1, F ty ~ r2, but neither can rewrite the other;
-    -- for example, they might both be Derived, or both Wanted
-    -- So we generate a new derived equality r1~r2
-    do { mb <- newDerived loc (mkTcEqPred rhs_i rhs)
-       ; case mb of
-           Just x  -> updWorkListTcS (extendWorkListEq (mkNonCanonical x))
-           Nothing -> return ()
-       ; return (Nothing, False) }
-
-   | Just ops <- isBuiltInSynFamTyCon_maybe tc
-   = do { let is = findFunEqsByTyCon funeqs tc
-        ; traceTcS "builtInCandidates: " $ ppr is
-        ; let interact = sfInteractInert ops args rhs
-        ; impMbs <- sequence
-                 [ do mb <- newDerived (ctev_loc iev) (mkTcEqPred lhs_ty rhs_ty)
-                      case mb of
-                        Just x -> return $ Just $ mkNonCanonical x
-                        Nothing -> return Nothing
-                 | CFunEqCan { cc_tyargs = iargs
-                             , cc_rhs = ixi
-                             , cc_ev = iev } <- is
-                 , Pair lhs_ty rhs_ty <- interact iargs ixi
-                 ]
-        ; let imps = catMaybes impMbs
-        ; unless (null imps) $ updWorkListTcS (extendWorkListEqs imps)
-        ; return (Nothing, False) }
+                                         , cc_tyargs = args, cc_fsk = fsk })
+  | Just (CFunEqCan { cc_ev = ev_i, cc_fsk = fsk_i }) <- matching_inerts
+  = if ev_i `canRewriteOrSame` ev
+    then  -- Rewrite work-item using inert
+      do { traceTcS "reactFunEq (discharge work item):" $
+           vcat [ text "workItem =" <+> ppr workItem
+                , text "inertItem=" <+> ppr ev_i ]
+         ; reactFunEq ev_i fsk_i ev fsk
+         ; stopWith ev "Inert rewrites work item" }
+    else  -- Rewrite intert using work-item
+      do { traceTcS "reactFunEq (rewrite inert item):" $
+           vcat [ text "workItem =" <+> ppr workItem
+                , text "inertItem=" <+> ppr ev_i ]
+         ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args workItem
+               -- 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" }
+
+  | Just ops <- isBuiltInSynFamTyCon_maybe tc
+  = do { let matching_funeqs = findFunEqsByTyCon funeqs tc
+       ; let interact = sfInteractInert ops args (lookupFlattenTyVar eqs fsk)
+             do_one (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = iev })
+                = mapM_ (emitNewDerivedEq (ctEvLoc iev)) 
+                        (interact iargs (lookupFlattenTyVar eqs ifsk))
+             do_one ct = pprPanic "interactFunEq" (ppr ct)
+       ; mapM_ do_one matching_funeqs
+       ; traceTcS "builtInCandidates 1: " $ vcat [ ptext (sLit "Candidates:") <+> ppr matching_funeqs
+                                                 , ptext (sLit "TvEqs:") <+> ppr eqs ]
+       ; return (ContinueWith workItem) }
 
   | otherwise
-  = return (Nothing, False)
+  = return (ContinueWith workItem)
   where
+    eqs    = inert_eqs inerts
     funeqs = inert_funeqs inerts
     matching_inerts = findFunEqs funeqs tc args
-    loc = ctev_loc ev
 
 interactFunEq _ wi = pprPanic "interactFunEq" (ppr wi)
 
+lookupFlattenTyVar :: TyVarEnv EqualCtList -> TcTyVar -> TcType
+-- ^ Look up a flatten-tyvar in the inert TyVarEqs
+lookupFlattenTyVar inert_eqs ftv 
+  = case lookupVarEnv inert_eqs ftv of
+      Just (CTyEqCan { cc_rhs = rhs } : _) -> rhs
+      _                                    -> mkTyVarTy ftv
 
-solveFunEq :: CtEvidence    -- From this  :: F tys ~ xi1
-           -> Type
-           -> CtEvidence    -- Solve this :: F tys ~ xi2
-           -> Type
+reactFunEq :: CtEvidence -> TcTyVar    -- From this  :: F tys ~ fsk1
+           -> CtEvidence -> TcTyVar    -- Solve this :: F tys ~ fsk2
            -> TcS ()
-solveFunEq from_this xi1 solve_this xi2
-  = do { ctevs <- xCtEvidence solve_this xev
-             -- No caching!  See Note [Cache-caused loops]
-             -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation]
-
-       ; emitWorkNC ctevs }
-  where
-    from_this_co = evTermCoercion $ ctEvTerm from_this
-
-    xev = XEvTerm [mkTcEqPred xi2 xi1] xcomp xdecomp
-
-    -- xcomp : [(xi2 ~ xi1)] -> (F tys ~ xi2)
-    xcomp [x] = EvCoercion (from_this_co `mkTcTransCo` mk_sym_co x)
-    xcomp _   = panic "No more goals!"
-
-    -- xdecomp : (F tys ~ xi2) -> [(xi2 ~ xi1)]
-    xdecomp x = [EvCoercion (mk_sym_co x `mkTcTransCo` from_this_co)]
-
-    mk_sym_co x = mkTcSymCo (evTermCoercion x)
+reactFunEq from_this fsk1 (CtGiven { ctev_evtm = tm, ctev_loc = loc }) fsk2
+  = do { let fsk_eq_co = mkTcSymCo (evTermCoercion tm)
+                         `mkTcTransCo` ctEvCoercion from_this
+                         -- :: fsk2 ~ fsk1
+             fsk_eq_pred = mkTcEqPred (mkTyVarTy fsk2) (mkTyVarTy fsk1)
+       ; new_ev <- newGivenEvVar loc (fsk_eq_pred, EvCoercion fsk_eq_co)
+       ; emitWorkNC [new_ev] }
+
+reactFunEq from_this fuv1 (CtWanted { ctev_evar = evar }) fuv2
+  = dischargeFmv evar fuv2 (ctEvCoercion from_this) (mkTyVarTy fuv1)
+
+reactFunEq _ _ solve_this@(CtDerived {}) _
+  = pprPanic "reactFunEq" (ppr solve_this)
 \end{code}
 
 Note [Cache-caused loops]
@@ -677,8 +675,8 @@ test when solving pairwise CFunEqCan.
 *********************************************************************************
 
 \begin{code}
-interactTyVarEq :: InertCans -> Ct -> TcS (Maybe InertCans, StopNowFlag)
--- CTyEqCans are always consumed, returning Stop
+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 })
   | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i }
                              <- findTyEqs (inert_eqs inerts) tv
@@ -686,9 +684,9 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs , cc_ev
                          , rhs_i `tcEqType` rhs ]
   =  -- Inert:     a ~ b
      -- Work item: a ~ b
-    do { when (isWanted ev) (setEvBind (ctev_evar ev) (ctEvTerm ev_i))
-       ; traceFireTcS workItem (ptext (sLit "Solved from inert"))
-       ; return (Nothing, True) }
+    do { when (isWanted ev) $
+         setEvBind (ctev_evar ev) (ctEvTerm ev_i)
+       ; stopWith ev "Solved from inert" }
 
   | Just tv_rhs <- getTyVar_maybe rhs
   , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i }
@@ -697,41 +695,97 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs , cc_ev
                          , rhs_i `tcEqType` mkTyVarTy tv ]
   =  -- Inert:     a ~ b
      -- Work item: b ~ a
-    do { when (isWanted ev) (setEvBind (ctev_evar ev)
-                                (EvCoercion (mkTcSymCo (evTermCoercion (ctEvTerm ev_i)))))
-       ; traceFireTcS workItem (ptext (sLit "Solved from inert (r)"))
-       ; return (Nothing, True) }
+    do { when (isWanted ev) $
+         setEvBind (ctev_evar ev)
+                   (EvCoercion (mkTcSymCo (ctEvCoercion ev_i)))
+       ; stopWith ev "Solved from inert (r)" }
 
   | otherwise
-  = do { mb_solved <- trySpontaneousSolve ev tv rhs
-       ; case mb_solved of
-           SPCantSolve   -- Includes givens
-              -> do { untch <- getUntouchables
-                    ; traceTcS "Can't solve tyvar equality"
-                          (vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv)
-                                , ppWhen (isMetaTyVar tv) $
-                                  nest 4 (text "Untouchable level of" <+> ppr tv
-                                          <+> text "is" <+> ppr (metaTyVarUntouchables tv))
-                                , text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs)
-                                , text "Untouchables =" <+> ppr untch ])
-                    ; (n_kicked, inerts') <- kickOutRewritable ev tv inerts
-                    ; traceFireTcS workItem $
-                      ptext (sLit "Kept as inert") <+> ppr_kicked n_kicked
-                    ; return (Just (addInertCan inerts' workItem), True) }
-
-
-           SPSolved new_tv
-              -- Post: tv ~ xi is now in TyBinds, no need to put in inerts as well
-              -- see Note [Spontaneously solved in TyBinds]
-              -> do { (n_kicked, inerts') <- kickOutRewritable givenFlavour new_tv inerts
-                    ; traceFireTcS workItem $
-                      ptext (sLit "Spontaneously solved") <+> ppr_kicked n_kicked
-                    ; return (Just inerts', True) } }
+  = do { untch <- getUntouchables
+       ; if canSolveByUnification untch ev tv rhs
+         then do { solveByUnification ev tv rhs
+                 ; n_kicked <- kickOutRewritable givenFlavour tv
+                               -- givenFlavour because the tv := xi is given
+                 ; return (Stop ev (ptext (sLit "Spontaneously solved") <+> ppr_kicked n_kicked)) }
+
+         else do { traceTcS "Can't solve tyvar equality"
+                       (vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv)
+                             , ppWhen (isMetaTyVar tv) $
+                               nest 4 (text "Untouchable level of" <+> ppr tv
+                                       <+> text "is" <+> ppr (metaTyVarUntouchables tv))
+                             , text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs)
+                             , text "Untouchables =" <+> ppr untch ])
+                 ; n_kicked <- kickOutRewritable ev tv
+                 ; updInertCans (\ ics -> addInertCan ics workItem)
+                 ; return (Stop ev (ptext (sLit "Kept as inert") <+> ppr_kicked n_kicked)) } }
 
 interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)
 
+-- @trySpontaneousSolve wi@ solves equalities where one side is a
+-- touchable unification variable.
+-- Returns True <=> spontaneous solve happened
+canSolveByUnification :: Untouchables -> CtEvidence -> TcTyVar -> Xi -> Bool
+canSolveByUnification untch gw tv xi
+  | isGiven gw   -- See Note [Touchables and givens]
+  = False
+
+  | isTouchableMetaTyVar untch tv
+  = case metaTyVarInfo tv of
+      SigTv -> is_tyvar xi
+      _     -> True
+
+  | otherwise    -- Untouchable
+  = False
+  where
+    is_tyvar xi
+      = case tcGetTyVar_maybe xi of
+          Nothing -> False
+          Just tv -> case tcTyVarDetails tv of
+                       MetaTv { mtv_info = info }
+                                   -> case info of
+                                        SigTv -> True
+                                        _     -> False
+                       SkolemTv {} -> True
+                       FlatSkol {} -> False
+                       RuntimeUnk  -> True
+
+solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS ()
+-- Solve with the identity coercion
+-- Precondition: kind(xi) is a sub-kind of kind(tv)
+-- Precondition: CtEvidence is Wanted or Derived
+-- See [New Wanted Superclass Work] to see why solveByUnification
+--     must work for Derived as well as Wanted
+-- Returns: workItem where
+--        workItem = the new Given constraint
+--
+-- NB: No need for an occurs check here, because solveByUnification always
+--     arises from a CTyEqCan, a *canonical* constraint.  Its invariants
+--     say that in (a ~ xi), the type variable a does not appear in xi.
+--     See TcRnTypes.Ct invariants.
+--
+-- Post: tv ~ xi is now in TyBinds, no need to put in inerts as well
+-- see Note [Spontaneously solved in TyBinds]
+solveByUnification wd tv xi
+  = do { let tv_ty = mkTyVarTy tv
+       ; traceTcS "Sneaky unification:" $
+                       vcat [text "Unifies:" <+> ppr tv <+> ptext (sLit ":=") <+> ppr xi,
+                             text "Coercion:" <+> pprEq tv_ty xi,
+                             text "Left Kind is:" <+> ppr (typeKind tv_ty),
+                             text "Right Kind is:" <+> ppr (typeKind xi) ]
+
+       ; let xi' = defaultKind xi
+               -- We only instantiate kind unification variables
+               -- with simple kinds like *, not OpenKind or ArgKind
+               -- cf TcUnify.uUnboundKVar
+
+       ; setWantedTyBind tv xi'
+       ; when (isWanted wd) $
+         setEvBind (ctEvId wd) (EvCoercion (mkTcNomReflCo xi')) }
+
+
 givenFlavour :: CtEvidence
 -- Used just to pass to kickOutRewritable
+-- and to guide 'flatten' for givens
 givenFlavour = CtGiven { ctev_pred = panic "givenFlavour:ev"
                        , ctev_evtm = panic "givenFlavour:tm"
                        , ctev_loc  = panic "givenFlavour:loc" }
@@ -760,24 +814,32 @@ these binds /and/ the inerts for potentially unsolved or other given equalities.
 kickOutRewritable :: CtEvidence   -- Flavour of the equality that is
                                   -- being added to the inert set
                   -> TcTyVar      -- The new equality is tv ~ ty
-                  -> InertCans
-                  -> TcS (Int, InertCans)
+                  -> TcS Int
 kickOutRewritable new_ev new_tv
-                  inert_cans@(IC { inert_eqs = tv_eqs
-                                 , inert_dicts  = dictmap
-                                 , inert_funeqs = funeqmap
-                                 , inert_irreds = irreds
-                                 , inert_insols = insols
-                                 , inert_no_eqs = no_eqs })
-  | new_tv `elemVarEnv` tv_eqs   -- Fast path: there is at least one equality for tv
-                                 -- so kick-out will do nothing
-  = return (0, inert_cans)
+  | not (new_ev `eqCanRewrite` new_ev)
+  = return 0  -- If new_ev can't rewrite itself, it can't rewrite
+              -- anything else, so no need to kick out anything
+              -- This is a common case: wanteds can't rewrite wanteds
+
   | otherwise
-  = do { traceTcS "kickOutRewritable" $
-            vcat [ text "tv = " <+> ppr new_tv
-                 , ptext (sLit "Kicked out =") <+> ppr kicked_out]
+  = do { ics <- getInertCans
+       ; let (kicked_out, ics') = kick_out new_ev new_tv ics
+       ; setInertCans ics'
        ; updWorkListTcS (appendWorkList kicked_out)
-       ; return (workListSize kicked_out, inert_cans_in) }
+
+       ; unless (isEmptyWorkList kicked_out) $
+         csTraceTcS $
+         hang (ptext (sLit "Kick out, tv =") <+> ppr new_tv)
+            2 (ppr kicked_out)
+       ; return (workListSize kicked_out) }
+
+kick_out :: CtEvidence -> TcTyVar -> InertCans -> (WorkList, InertCans)
+kick_out new_ev new_tv (IC { inert_eqs = tv_eqs
+                           , inert_dicts  = dictmap
+                           , inert_funeqs = funeqmap
+                           , inert_irreds = irreds
+                           , inert_insols = insols })
+  = (kicked_out, inert_cans_in)
   where
                 -- NB: Notice that don't rewrite
                 -- inert_solved_dicts, and inert_solved_funeqs
@@ -787,52 +849,39 @@ kickOutRewritable new_ev new_tv
                        , inert_dicts = dicts_in
                        , inert_funeqs = feqs_in
                        , inert_irreds = irs_in
-                       , inert_insols = insols_in
-                       , inert_no_eqs = no_eqs }
+                       , inert_insols = insols_in }
 
-    kicked_out = WorkList { wl_eqs    = tv_eqs_out
-                          , wl_funeqs = foldrBag insertDeque emptyDeque feqs_out
-                          , wl_rest   = bagToList (dicts_out `andCts` irs_out
-                                                   `andCts` insols_out) }
+    kicked_out = WL { wl_eqs    = tv_eqs_out
+                    , wl_funeqs = foldrBag insertDeque emptyDeque feqs_out
+                    , wl_rest   = bagToList (dicts_out `andCts` irs_out
+                                             `andCts` insols_out)
+                    , wl_implics = emptyBag }
 
     (tv_eqs_out,  tv_eqs_in) = foldVarEnv kick_out_eqs ([], emptyVarEnv) tv_eqs
-    (feqs_out,   feqs_in)    = partitionFunEqs  kick_out_ct    funeqmap
-    (dicts_out,  dicts_in)   = partitionDicts   kick_out_ct    dictmap
+    (feqs_out,   feqs_in)    = partitionFunEqs  kick_out_ct funeqmap
+    (dicts_out,  dicts_in)   = partitionDicts   kick_out_ct dictmap
     (irs_out,    irs_in)     = partitionBag     kick_out_irred irreds
     (insols_out, insols_in)  = partitionBag     kick_out_ct    insols
       -- Kick out even insolubles; see Note [Kick out insolubles]
 
     kick_out_ct :: Ct -> Bool
-    kick_out_ct ct =  new_ev `canRewrite` ctEvidence ct
+    kick_out_ct ct =  eqCanRewrite new_ev (ctEvidence ct)
                    && new_tv `elemVarSet` tyVarsOfCt ct
          -- See Note [Kicking out inert constraints]
 
     kick_out_irred :: Ct -> Bool
-    kick_out_irred ct =  new_ev `canRewrite` ctEvidence ct
+    kick_out_irred ct =  eqCanRewrite new_ev (ctEvidence ct)
                       && new_tv `elemVarSet` closeOverKinds (tyVarsOfCt ct)
           -- See Note [Kicking out Irreds]
 
-    kick_out_eqs :: EqualCtList -> ([Ct], TyVarEnv EqualCtList) 
+    kick_out_eqs :: EqualCtList -> ([Ct], TyVarEnv EqualCtList)
                  -> ([Ct], TyVarEnv EqualCtList)
     kick_out_eqs eqs (acc_out, acc_in)
       = (eqs_out ++ acc_out, case eqs_in of
                                []      -> acc_in
                                (eq1:_) -> extendVarEnv acc_in (cc_tyvar eq1) eqs_in)
       where
-        (eqs_out, eqs_in) = partition kick_out_eq eqs
-
-
-    kick_out_eq :: Ct -> Bool
-    kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs, cc_ev = ev })
-      =  (new_ev `canRewrite` ev)  -- See Note [Delicate equality kick-out]
-      && (new_tv `elemVarSet` kind_vars ||    -- (1)
-          (not (ev `canRewrite` new_ev) &&    -- (2)
-           new_tv `elemVarSet` (extendVarSet (tyVarsOfType rhs) tv)))
-      where
-        kind_vars = tyVarsOfType (tyVarKind tv) `unionVarSet`
-                    tyVarsOfType (typeKind rhs)
-
-    kick_out_eq other_ct = pprPanic "kick_out_eq" (ppr other_ct)
+        (eqs_out, eqs_in) = partition kick_out_ct eqs
 \end{code}
 
 Note [Kicking out inert constraints]
@@ -865,7 +914,6 @@ closeOverKinds to make sure we see k2.
 This is not pretty. Maybe (~) should have kind 
    (~) :: forall k1 k1. k1 -> k2 -> Constraint
 
-
 Note [Kick out insolubles]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we have an insoluble alpha ~ [alpha], which is insoluble
@@ -877,8 +925,17 @@ outer type constructors match.
 
 Note [Delicate equality kick-out]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When adding an equality (a ~ xi), we kick out an inert type-variable
-equality (b ~ phi) in two cases
+When adding an work-item CTyEqCan (a ~ xi), we kick out an inert
+CTyEqCan (b ~ phi) when
+
+  a) the work item can rewrite the inert item
+
+AND one of the following hold
+
+(0) If the new tyvar is the same as the old one
+      Work item: [G] a ~ blah
+      Inert:     [W] a ~ foo
+    A particular case is when flatten-skolems get their value we must propagate
 
 (1) If the new tyvar appears in the kind vars of the LHS or RHS of
     the inert.  Example:
@@ -889,7 +946,8 @@ equality (b ~ phi) in two cases
     and can subsequently unify.
 
 (2) If the new tyvar appears in the RHS of the inert
-    AND the inert cannot rewrite the work item
+    AND not (the inert can rewrite the work item)   <---------------------------------
+
           Work item:  [G] a ~ b
           Inert:      [W] b ~ [a]
     Now at this point the work item cannot be further rewritten by the
@@ -903,65 +961,13 @@ equality (b ~ phi) in two cases
          Work item: [W] a ~ Int
          Inert:     [W] b ~ [a]
     No need to kick out the inert, beause the inert substitution is not
-    necessarily idemopotent.  See Note [Non-idempotent inert substitution].
+    necessarily idemopotent.  See Note [Non-idempotent inert substitution]
+    in TcFlatten.
 
+          Work item:  [G] a ~ Int
+          Inert:      [G] b ~ [a]
 See also Note [Detailed InertCans Invariants]
 
-\begin{code}
-data SPSolveResult = SPCantSolve
-                   | SPSolved TcTyVar
-                     -- We solved this /unification/ variable to some type using reflexivity
-
--- SPCantSolve means that we can't do the unification because e.g. the variable is untouchable
--- SPSolved workItem' gives us a new *given* to go on
-
--- @trySpontaneousSolve wi@ solves equalities where one side is a
--- touchable unification variable.
-trySpontaneousSolve :: CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
-trySpontaneousSolve gw tv1 xi
-  | isGiven gw   -- See Note [Touchables and givens]
-  = return SPCantSolve
-
-  | Just tv2 <- tcGetTyVar_maybe xi
-  = do { tch1 <- isTouchableMetaTyVarTcS tv1
-       ; tch2 <- isTouchableMetaTyVarTcS tv2
-       ; case (tch1, tch2) of
-           (True,  True)  -> trySpontaneousEqTwoWay gw tv1 tv2
-           (True,  False) -> trySpontaneousEqOneWay gw tv1 xi
-           (False, True)  -> trySpontaneousEqOneWay gw tv2 (mkTyVarTy tv1)
-           _              -> return SPCantSolve }
-  | otherwise
-  = do { tch1 <- isTouchableMetaTyVarTcS tv1
-       ; if tch1 then trySpontaneousEqOneWay gw tv1 xi
-                 else return SPCantSolve }
-
-----------------
-trySpontaneousEqOneWay :: CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
--- tv is a MetaTyVar, not untouchable
-trySpontaneousEqOneWay gw tv xi
-  | not (isSigTyVar tv) || isTyVarTy xi
-  , typeKind xi `tcIsSubKind` tyVarKind tv
-  = solveWithIdentity gw tv xi
-  | otherwise -- Still can't solve, sig tyvar and non-variable rhs
-  = return SPCantSolve
-
-----------------
-trySpontaneousEqTwoWay :: CtEvidence -> TcTyVar -> TcTyVar -> TcS SPSolveResult
--- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here
-
-trySpontaneousEqTwoWay gw tv1 tv2
-  | k1 `tcIsSubKind` k2 && nicer_to_update_tv2
-  = solveWithIdentity gw tv2 (mkTyVarTy tv1)
-  | k2 `tcIsSubKind` k1
-  = solveWithIdentity gw tv1 (mkTyVarTy tv2)
-  | otherwise
-  = return SPCantSolve
-  where
-    k1 = tyVarKind tv1
-    k2 = tyVarKind tv2
-    nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2)
-\end{code}
-
 Note [Avoid double unifications]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The spontaneous solver has to return a given which mentions the unified unification
@@ -980,42 +986,6 @@ See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding
 double unifications is the main reason we disallow touchable
 unification variables as RHS of type family equations: F xis ~ alpha.
 
-\begin{code}
-solveWithIdentity :: CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
--- Solve with the identity coercion
--- Precondition: kind(xi) is a sub-kind of kind(tv)
--- Precondition: CtEvidence is Wanted or Derived
--- See [New Wanted Superclass Work] to see why solveWithIdentity
---     must work for Derived as well as Wanted
--- Returns: workItem where
---        workItem = the new Given constraint
---
--- NB: No need for an occurs check here, because solveWithIdentity always
---     arises from a CTyEqCan, a *canonical* constraint.  Its invariants
---     say that in (a ~ xi), the type variable a does not appear in xi.
---     See TcRnTypes.Ct invariants.
-solveWithIdentity wd tv xi
-  = do { let tv_ty = mkTyVarTy tv
-       ; traceTcS "Sneaky unification:" $
-                       vcat [text "Unifies:" <+> ppr tv <+> ptext (sLit ":=") <+> ppr xi,
-                             text "Coercion:" <+> pprEq tv_ty xi,
-                             text "Left Kind is:" <+> ppr (typeKind tv_ty),
-                             text "Right Kind is:" <+> ppr (typeKind xi) ]
-
-       ; let xi' = defaultKind xi
-               -- We only instantiate kind unification variables
-               -- with simple kinds like *, not OpenKind or ArgKind
-               -- cf TcUnify.uUnboundKVar
-
-       ; setWantedTyBind tv xi'
-       ; let refl_evtm = EvCoercion (mkTcNomReflCo xi')
-
-       ; when (isWanted wd) $
-              setEvBind (ctev_evar wd) refl_evtm
-
-       ; return (SPSolved tv) }
-\end{code}
-
 
 
 Note [Superclasses and recursive dictionaries]
@@ -1363,38 +1333,23 @@ To achieve this required some refactoring of FunDeps.lhs (nicer
 now!).
 
 \begin{code}
-rewriteWithFunDeps :: [Equation CtLoc] -> TcS [Ct]
+rewriteWithFunDeps :: [Equation CtLoc] -> TcS ()
 -- NB: The returned constraints are all Derived
 -- Post: returns no trivial equalities (identities) and all EvVars returned are fresh
 rewriteWithFunDeps eqn_pred_locs
- = do { fd_cts <- mapM instFunDepEqn eqn_pred_locs
-      ; return (concat fd_cts) }
+ = mapM_ instFunDepEqn eqn_pred_locs
 
-instFunDepEqn :: Equation CtLoc -> TcS [Ct]
+instFunDepEqn :: Equation CtLoc -> TcS ()
 -- Post: Returns the position index as well as the corresponding FunDep equality
 instFunDepEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc })
   = do { (subst, _) <- instFlexiTcS tvs  -- Takes account of kind substitution
-       ; foldM (do_one subst) [] eqs }
+       ; mapM_ (do_one subst) eqs }
   where
-    do_one subst ievs (FDEq { fd_ty_left = ty1, fd_ty_right = ty2 })
-       | tcEqType sty1 sty2
-       = return ievs -- Return no trivial equalities
-       | otherwise
-       = do { mb_eqv <- newDerived loc (mkTcEqPred sty1 sty2)
-            ; case mb_eqv of
-                 Just ev -> return (mkNonCanonical (ev {ctev_loc = loc}) : ievs)
-                 Nothing -> return ievs }
-                   -- We are eventually going to emit FD work back in the work list so
-                   -- it is important that we only return the /freshly created/ and not
-                   -- some existing equality!
-       where
-         sty1 = Type.substTy subst ty1
-         sty2 = Type.substTy subst ty2
+    do_one subst (FDEq { fd_ty_left = ty1, fd_ty_right = ty2 })
+       = emitNewDerivedEq loc (Pair (Type.substTy subst ty1) (Type.substTy subst ty2))
 \end{code}
 
 
-
-
 *********************************************************************************
 *                                                                               *
                        The top-reaction Stage
@@ -1402,23 +1357,15 @@ instFunDepEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc })
 *********************************************************************************
 
 \begin{code}
-topReactionsStage :: WorkItem -> TcS StopOrContinue
+topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)
 topReactionsStage wi
  = do { inerts <- getTcSInerts
       ; tir <- doTopReact inerts wi
       ; case tir of
-          NoTopInt -> return (ContinueWith wi)
-          SomeTopInt rule what_next
-                   -> do { traceFireTcS wi $
-                           ptext (sLit "Top react:") <+> text rule
-                         ; return what_next } }
+          ContinueWith wi -> return (ContinueWith wi)
+          Stop ev s       -> return (Stop ev (ptext (sLit "Top react:") <+> s)) }
 
-data TopInteractResult
- = NoTopInt
- | SomeTopInt { tir_rule :: String, tir_new_item :: StopOrContinue }
-
-
-doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
+doTopReact :: InertSet -> WorkItem -> TcS (StopOrContinue Ct)
 -- The work item does not react with the inert set, so try interaction with top-level
 -- instances. Note:
 --
@@ -1429,30 +1376,26 @@ doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
 --   (b) See Note [Given constraint that matches an instance declaration]
 --       for some design decisions for given dictionaries.
 
-doTopReact inerts workItem
-  = do { traceTcS "doTopReact" (ppr workItem)
-       ; case workItem of
-           CDictCan { cc_ev = fl, cc_class = cls, cc_tyargs = xis }
-              -> doTopReactDict inerts fl cls xis
-
-           CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = args , cc_rhs = xi }
-              -> doTopReactFunEq workItem fl tc args xi
-
+doTopReact inerts work_item
+  = do { traceTcS "doTopReact" (ppr work_item)
+       ; case work_item of
+           CDictCan {}  -> doTopReactDict inerts work_item
+           CFunEqCan {} -> doTopReactFunEq work_item
            _  -> -- Any other work item does not react with any top-level equations
-                 return NoTopInt  }
+                 return (ContinueWith work_item)  }
 
 --------------------
-doTopReactDict :: InertSet -> CtEvidence -> Class -> [Xi] -> TcS TopInteractResult
+doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct)
 -- Try to use type-class instance declarations to simplify the constraint
-doTopReactDict inerts fl cls xis
+doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls
+                                          , cc_tyargs = xis })
   | not (isWanted fl)   -- Never use instances for Given or Derived constraints
   = try_fundeps_and_return
 
   | Just ev <- lookupSolvedDict inerts cls xis   -- Cached
-  , ctEvCheckDepth (ctLocDepth (ctev_loc fl)) ev
+  , ctEvCheckDepth (ctLocDepth loc) ev
   = do { setEvBind dict_id (ctEvTerm ev);
-       ; return $ SomeTopInt { tir_rule = "Dict/Top (cached)"
-                             , tir_new_item = Stop } }
+       ; stopWith fl "Dict/Top (cached)" }
 
   | otherwise  -- Not cached
    = do { lkup_inst_res <- matchClassInst inerts cls xis loc
@@ -1461,20 +1404,18 @@ doTopReactDict inerts fl cls xis
                                           ; solve_from_instance wtvs ev_term }
                NoInstance -> try_fundeps_and_return }
    where
-     dict_id = ctEvId fl
+     dict_id = ASSERT( isWanted fl ) ctEvId fl
      pred = mkClassPred cls xis
-     loc = ctev_loc fl
+     loc = ctEvLoc fl
 
-     solve_from_instance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult
+     solve_from_instance :: [CtEvidence] -> EvTerm -> TcS (StopOrContinue Ct)
       -- Precondition: evidence term matches the predicate workItem
      solve_from_instance evs ev_term
         | null evs
         = do { traceTcS "doTopReact/found nullary instance for" $
                ppr dict_id
              ; setEvBind dict_id ev_term
-             ; return $
-               SomeTopInt { tir_rule = "Dict/Top (solved, no new work)"
-                          , tir_new_item = Stop } }
+             ; stopWith fl "Dict/Top (solved, no new work)" }
         | otherwise
         = do { traceTcS "doTopReact/found non-nullary instance for" $
                ppr dict_id
@@ -1482,9 +1423,7 @@ doTopReactDict inerts fl cls xis
              ; let mk_new_wanted ev
                        = mkNonCanonical (ev {ctev_loc = bumpCtLocDepth CountConstraints loc })
              ; updWorkListTcS (extendWorkListCts (map mk_new_wanted evs))
-             ; return $
-               SomeTopInt { tir_rule     = "Dict/Top (solved, more work)"
-                          , tir_new_item = Stop } }
+             ; stopWith fl "Dict/Top (solved, more work)" }
 
      -- We didn't solve it; so try functional dependencies with
      -- the instance environment, and return
@@ -1497,66 +1436,135 @@ doTopReactDict inerts fl cls xis
                   fd_eqns = [ fd { fd_loc = loc { ctl_origin = FunDepOrigin2 pred (ctl_origin loc)
                                                                              inst_pred inst_loc } }
                             | fd@(FDEqn { fd_loc = inst_loc, fd_pred1 = inst_pred })
-                                 <- improveFromInstEnv instEnvs pred ]
-            ; fd_work <- rewriteWithFunDeps fd_eqns
-            ; unless (null fd_work) $
-              do { traceTcS "Addig FD work" (ppr pred $$ vcat (map pprEquation fd_eqns) $$ ppr fd_work)
-                 ; updWorkListTcS (extendWorkListEqs fd_work) }
-            ; return NoTopInt }
+                            <- improveFromInstEnv instEnvs pred ]
+            ; rewriteWithFunDeps fd_eqns
+            ; continueWith work_item }
 
---------------------
-doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi -> TcS TopInteractResult
-doTopReactFunEq _ct fl fun_tc args xi
-  = ASSERT(isSynFamilyTyCon fun_tc) -- No associated data families have
-                                     -- reached this far
-    -- Look in the cache of solved funeqs
-    do { fun_eq_cache <- getTcSInerts >>= (return . inert_solved_funeqs)
-       ; case findFunEq fun_eq_cache fun_tc args of {
-           Just (ctev, rhs_ty)
-             | ctev `canRewriteOrSame` fl  -- See Note [Cached solved FunEqs]
-             -> ASSERT( not (isDerived ctev) )
-                succeed_with "Fun/Cache" (evTermCoercion (ctEvTerm ctev)) rhs_ty ;
-           _other ->
+doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)
 
+--------------------
+doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct)
+doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc
+                                     , cc_tyargs = args , cc_fsk = fsk })
+  = ASSERT(isSynFamilyTyCon fam_tc) -- No associated data families
+                                    -- have reached this far
+    ASSERT( not (isDerived old_ev) )   -- CFunEqCan is never Derived
     -- Look up in top-level instances, or built-in axiom
-    do { match_res <- matchFam fun_tc args   -- See Note [MATCHING-SYNONYMS]
+    do { match_res <- matchFam fam_tc args   -- See Note [MATCHING-SYNONYMS]
        ; case match_res of {
-           Nothing -> do { try_improvement; return NoTopInt } ;
-           Just (co, ty) ->
+           Nothing -> do { try_improvement; continueWith work_item } ;
+           Just (ax_co, rhs_ty)
 
     -- Found a top-level instance
-    do {    -- Add it to the solved goals
-         unless (isDerived fl) (addSolvedFunEq fun_tc args fl xi)
 
-       ; succeed_with "Fun/Top" co ty } } } } }
+    | Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty
+    , isSynFamilyTyCon tc
+    , tc_args `lengthIs` tyConArity tc    -- Short-cut
+    -> shortCutReduction old_ev fsk ax_co tc tc_args
+         -- Try shortcut; see Note [Short cut for top-level reaction]
+
+    | isGiven old_ev  -- Not shortcut
+    -> do { let final_co = mkTcSymCo (ctEvCoercion old_ev) `mkTcTransCo` ax_co
+                -- final_co :: fsk ~ rhs_ty
+          ; new_ev <- newGivenEvVar deeper_loc (mkTcEqPred (mkTyVarTy fsk) rhs_ty,
+                                                EvCoercion final_co)
+          ; emitWorkNC [new_ev]   -- Non-cannonical; that will mean we flatten rhs_ty
+          ; stopWith old_ev "Fun/Top (given)" }
+
+    | not (fsk `elemVarSet` tyVarsOfType rhs_ty)
+    -> do { dischargeFmv (ctEvId old_ev) fsk ax_co rhs_ty
+          ; traceTcS "doTopReactFunEq" $
+            vcat [ text "old_ev:" <+> ppr old_ev
+                 , nest 2 (text ":=") <+> ppr ax_co ]
+          ; stopWith old_ev "Fun/Top (wanted)" }
+
+    | otherwise -- We must not assign ufsk := ...ufsk...!
+    -> do { alpha_ty <- newFlexiTcSTy (tyVarKind fsk)
+          ; new_ev <- newWantedEvVarNC loc (mkTcEqPred alpha_ty rhs_ty)
+          ; let final_co = ax_co `mkTcTransCo` mkTcSymCo (ctEvCoercion new_ev)
+              --    ax_co :: fam_tc args ~ rhs_ty
+              --       ev :: alpha ~ rhs_ty
+              --     ufsk := alpha
+              -- final_co :: fam_tc args ~ alpha
+          ; dischargeFmv (ctEvId old_ev) fsk final_co alpha_ty
+          ; traceTcS "doTopReactFunEq (occurs)" $
+            vcat [ text "old_ev:" <+> ppr old_ev
+                 , nest 2 (text ":=") <+> ppr final_co
+                 , text "new_ev:" <+> ppr new_ev ]
+          ; emitWorkNC [new_ev]
+              -- By emitting this as non-canonical, we deal with all
+              -- flattening, occurs-check, and ufsk := ufsk issues
+          ; stopWith old_ev "Fun/Top (wanted)" } } }
   where
-    loc = ctev_loc fl
+    loc = ctEvLoc old_ev
+    deeper_loc = bumpCtLocDepth CountTyFunApps loc
 
     try_improvement
-      | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc
-      = do { let eqns = sfInteractTop ops args xi
-           ; impsMb <- mapM (\(Pair x y) -> newDerived loc (mkTcEqPred x y)) eqns
-           ; let work = map mkNonCanonical (catMaybes impsMb)
-           ; unless (null work) (updWorkListTcS (extendWorkListEqs work)) }
+      | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+      = do { inert_eqs <- getInertEqs
+           ; let eqns = sfInteractTop ops args (lookupFlattenTyVar inert_eqs fsk)
+           ; mapM_ (emitNewDerivedEq loc) eqns }
       | otherwise
       = return ()
 
-    succeed_with :: String -> TcCoercion -> TcType -> TcS TopInteractResult
-    succeed_with str co rhs_ty    -- co :: fun_tc args ~ rhs_ty
-      = do { ctevs <- xCtEvidence fl xev
-           ; traceTcS ("doTopReactFunEq " ++ str) (ppr ctevs)
-           ; case ctevs of
-               [ctev] -> updWorkListTcS $ extendWorkListEq $
-                         mkNonCanonical (ctev { ctev_loc = bumpCtLocDepth CountTyFunApps loc })
-               ctevs -> -- No subgoal (because it's cached)
-                        ASSERT( null ctevs) return ()
-           ; return $ SomeTopInt { tir_rule = str
-                                 , tir_new_item = Stop } }
-      where
-        xdecomp x = [EvCoercion (mkTcSymCo co `mkTcTransCo` evTermCoercion x)]
-        xcomp [x] = EvCoercion (co `mkTcTransCo` evTermCoercion x)
-        xcomp _   = panic "No more goals!"
-        xev = XEvTerm [mkTcEqPred rhs_ty xi] xcomp xdecomp
+doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w)
+
+shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion
+                  -> TyCon -> [TcType] -> TcS (StopOrContinue Ct)
+shortCutReduction old_ev fsk ax_co fam_tc tc_args
+  | isGiven old_ev
+  = do { (xis, cos) <- flattenMany (FE { fe_ev = old_ev, fe_mode = FM_FlattenAll }) tc_args
+               -- ax_co :: F args ~ G tc_args
+               -- cos   :: xis ~ tc_args
+               -- old_ev :: F args ~ fsk
+               -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk
+
+       ; new_ev <- newGivenEvVar deeper_loc
+                         ( mkTcEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk)
+                         , EvCoercion (mkTcTyConAppCo Nominal fam_tc cos
+                                        `mkTcTransCo` mkTcSymCo ax_co
+                                        `mkTcTransCo` ctEvCoercion old_ev) )
+
+       ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc, cc_tyargs = xis, cc_fsk = fsk }
+       ; updWorkListTcS (extendWorkListFunEq new_ct)
+       ; stopWith old_ev "Fun/Top (given, shortcut)" }
+
+  | otherwise
+  = ASSERT( not (isDerived old_ev) )   -- Caller ensures this
+    do { (xis, cos) <- flattenMany (FE { fe_ev = old_ev, fe_mode = FM_FlattenAll }) tc_args
+               -- ax_co :: F args ~ G tc_args
+               -- cos   :: xis ~ tc_args
+               -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk
+               -- new_ev :: G xis ~ fsk
+               -- old_ev :: F args ~ fsk := ax_co ; sym (G cos) ; new_ev
+
+       ; new_ev <- newWantedEvVarNC loc (mkTcEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk))
+       ; setEvBind (ctEvId old_ev)
+                   (EvCoercion (ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal fam_tc cos)
+                                      `mkTcTransCo` ctEvCoercion new_ev))
+
+       ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc, cc_tyargs = xis, cc_fsk = fsk }
+       ; updWorkListTcS (extendWorkListFunEq new_ct)
+       ; stopWith old_ev "Fun/Top (wanted, shortcut)" }
+  where
+    loc = ctEvLoc old_ev
+    deeper_loc = bumpCtLocDepth CountTyFunApps loc
+
+dischargeFmv :: EvVar -> TcTyVar -> TcCoercion -> TcType -> TcS ()
+-- (dischargeFmv x fmv co ty)
+--     [W] x :: F tys ~ fuv
+--        co :: F tys ~ ty
+-- Precondition: fuv is not filled, and fuv `notElem` ty
+--
+-- Then set fuv := ty,
+--      set x := co
+--      kick out any inert things that are now rewritable
+dischargeFmv evar fmv co xi
+  = ASSERT2( not (fmv `elemVarSet` tyVarsOfType xi), ppr evar $$ ppr fmv $$ ppr xi )
+    do { setWantedTyBind fmv xi
+       ; setEvBind evar (EvCoercion co)
+       ; n_kicked <- kickOutRewritable givenFlavour fmv
+       ; traceTcS "dischargeFuv" (ppr fmv <+> equals <+> ppr xi $$ ppr_kicked n_kicked) }
 \end{code}
 
 Note [Cached solved FunEqs]
@@ -1836,13 +1844,15 @@ matchClassInst _ clas [ ty ] _
   -}
   makeDict evLit
     | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
+          -- co_dict :: KnownNat n ~ SNat n
     , [ meth ]   <- classMethods clas
     , Just tcRep <- tyConAppTyCon_maybe -- SNat
                       $ funResultTy         -- SNat n
                       $ dropForAlls         -- KnownNat n => SNat n
                       $ idType meth         -- forall n. KnownNat n => SNat n
     , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
-    = return (GenInst [] $ mkEvCast (EvLit evLit) (mkTcTransCo co_dict co_rep))
+          -- SNat n ~ Integer
+    = return (GenInst [] $ mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep)))
 
     | otherwise
     = panicTcS (text "Unexpected evidence for" <+> ppr (className clas)
@@ -1909,7 +1919,7 @@ matchClassInst inerts clas tys loc
             { evc_vars <- instDFunConstraints loc theta
             ; let new_ev_vars = freshGoals evc_vars
                       -- new_ev_vars are only the real new variables that can be emitted
-                  dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars)
+                  dfun_app = EvDFunApp dfun_id tys (map (ctEvTerm . fst) evc_vars)
             ; return $ GenInst new_ev_vars dfun_app } }
 
      givens_for_this_clas :: Cts
@@ -2028,10 +2038,9 @@ requestCoercible :: CtLoc -> TcType -> TcType
                         , TcCoercion )      -- Coercion witnessing (Coercible t1 t2)
 requestCoercible loc ty1 ty2
   = ASSERT2( typeKind ty1 `tcEqKind` typeKind ty2, ppr ty1 <+> ppr ty2)
-    do { mb_ev <- newWantedEvVarNonrec loc' (mkCoerciblePred ty1 ty2)
-       ; case mb_ev of
-           Fresh ev     -> return ( [ev], evTermCoercion (ctEvTerm ev) )
-           Cached ev_tm -> return ( [],   evTermCoercion ev_tm ) }
+    do { (new_ev, freshness) <- newWantedEvVarNonrec loc' (mkCoerciblePred ty1 ty2)
+       ; return ( case freshness of { Fresh -> [new_ev]; Cached -> [] }
+                , ctEvCoercion new_ev) }
            -- Evidence for a Coercible constraint is always a coercion t1 ~R t2
   where
      loc' = bumpCtLocDepth CountConstraints loc
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index ed68690bfb..d6f37c8f96 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -1,4 +1,4 @@
-o%
+%
 % (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
@@ -53,7 +53,7 @@ module TcMType (
   zonkTcTyVarBndr, zonkTcType, zonkTcTypes, zonkTcThetaType,
 
   zonkTcKind, defaultKindVarToStar,
-  zonkEvVar, zonkWC, zonkFlats, zonkId, zonkCt, zonkCts, zonkSkolemInfo,
+  zonkEvVar, zonkWC, zonkFlats, zonkId, zonkCt, zonkSkolemInfo,
 
   tcGetGlobalTyVars,
   ) where
@@ -63,10 +63,8 @@ module TcMType (
 -- friends:
 import TypeRep
 import TcType
-import TcEvidence
 import Type
 import Class
-import TyCon
 import Var
 
 -- others:
@@ -313,9 +311,10 @@ newMetaTyVar meta_info kind
   = do  { uniq <- newUnique
         ; let name = mkTcTyVarName uniq s
               s = case meta_info of
-                        PolyTv -> fsLit "s"
-                        TauTv  -> fsLit "t"
-                        SigTv  -> fsLit "a"
+                        PolyTv     -> fsLit "s"
+                        TauTv      -> fsLit "t"
+                        FlatMetaTv -> fsLit "fmv"
+                        SigTv      -> fsLit "a"
         ; details <- newMetaDetails meta_info
         ; return (mkTcTyVar name kind details) }
 
@@ -595,6 +594,7 @@ skolemiseUnboundMetaTyVar tv details
               final_name = mkInternalName uniq (getOccName tv) span
               final_tv   = mkTcTyVar final_name final_kind details
 
+        ; traceTc "Skolemising" (ppr tv <+> ptext (sLit ":=") <+> ppr final_tv)
         ; writeMetaTyVar tv (mkTyVarTy final_tv)
         ; return final_tv }
 \end{code}
@@ -667,7 +667,7 @@ a \/\a in the final result but all the occurrences of a will be zonked to ()
 
 %************************************************************************
 %*                                                                      *
-              Zonking
+              Zonking types
 %*                                                                      *
 %************************************************************************
 
@@ -686,8 +686,6 @@ tcGetGlobalTyVars
   where
 \end{code}
 
------------------  Type variables
-
 \begin{code}
 zonkTcTypeAndFV :: TcType -> TcM TyVarSet
 -- Zonk a type and take its free variables
@@ -728,13 +726,15 @@ zonkTcPredType :: TcPredType -> TcM TcPredType
 zonkTcPredType = zonkTcType
 \end{code}
 
----------------  Constraints
+%************************************************************************
+%*                                                                      *
+              Zonking constraints
+%*                                                                      *
+%************************************************************************
 
 \begin{code}
 zonkImplication :: Implication -> TcM (Bag Implication)
-zonkImplication implic@(Implic { ic_untch  = untch
-                               , ic_binds  = binds_var
-                               , ic_skols  = skols
+zonkImplication implic@(Implic { ic_skols  = skols
                                , ic_given  = given
                                , ic_wanted = wanted
                                , ic_info   = info })
@@ -742,12 +742,11 @@ zonkImplication implic@(Implic { ic_untch  = untch
                                                 -- as Trac #7230 showed
        ; given'  <- mapM zonkEvVar given
        ; info'   <- zonkSkolemInfo info
-       ; wanted' <- zonkWCRec binds_var untch wanted
+       ; wanted' <- zonkWCRec wanted
        ; if isEmptyWC wanted'
          then return emptyBag
          else return $ unitBag $
-              implic { ic_fsks   = []  -- Zonking removes all FlatSkol tyvars
-                     , ic_skols  = skols'
+              implic { ic_skols  = skols'
                      , ic_given  = given'
                      , ic_wanted = wanted'
                      , ic_info   = info' } }
@@ -757,105 +756,25 @@ zonkEvVar var = do { ty' <- zonkTcType (varType var)
                    ; return (setVarType var ty') }
 
 
-zonkWC :: EvBindsVar -- May add new bindings for wanted family equalities in here
-       -> WantedConstraints -> TcM WantedConstraints
-zonkWC binds_var wc
-  = do { untch <- getUntouchables
-       ; zonkWCRec binds_var untch wc }
+zonkWC :: WantedConstraints -> TcM WantedConstraints
+zonkWC wc = zonkWCRec wc
 
-zonkWCRec :: EvBindsVar
-          -> Untouchables
-          -> WantedConstraints -> TcM WantedConstraints
-zonkWCRec binds_var untch (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
-  = do { flat'   <- zonkFlats binds_var untch flat
+zonkWCRec :: WantedConstraints -> TcM WantedConstraints
+zonkWCRec (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
+  = do { flat'   <- zonkFlats flat
        ; implic' <- flatMapBagM zonkImplication implic
-       ; insol'  <- zonkCts insol -- No need to do the more elaborate zonkFlats thing
+       ; insol'  <- zonkFlats insol
        ; return (WC { wc_flat = flat', wc_impl = implic', wc_insol = insol' }) }
-
-zonkFlats :: EvBindsVar -> Untouchables -> Cts -> TcM Cts
--- This zonks and unflattens a bunch of flat constraints
--- See Note [Unflattening while zonking]
-zonkFlats binds_var untch cts
-  = do { -- See Note [How to unflatten]
-         cts <- foldrBagM unflatten_one emptyCts cts
-       ; zonkCts cts }
-  where
-    unflatten_one orig_ct cts
-      = do { zct <- zonkCt orig_ct                -- First we need to fully zonk
-           ; mct <- try_zonk_fun_eq orig_ct zct   -- Then try to solve if family equation
-           ; return $ maybe cts (`consBag` cts) mct }
-
-    try_zonk_fun_eq orig_ct zct   -- See Note [How to unflatten]
-      | EqPred ty_lhs ty_rhs <- classifyPredType (ctPred zct)
-          -- NB: zonking de-classifies the constraint,
-          --     so we can't look for CFunEqCan
-      , Just tv <- getTyVar_maybe ty_rhs
-      , ASSERT2( not (isFloatedTouchableMetaTyVar untch tv), ppr tv )
-        isTouchableMetaTyVar untch tv
-      , not (isSigTyVar tv) || isTyVarTy ty_lhs     -- Never unify a SigTyVar with a non-tyvar
-      , typeKind ty_lhs `tcIsSubKind` tyVarKind tv  -- c.f. TcInteract.trySpontaneousEqOneWay
-      , not (tv `elemVarSet` tyVarsOfType ty_lhs)   -- Do not construct an infinite type
-      = ASSERT2( case tcSplitTyConApp_maybe ty_lhs of { Just (tc,_) -> isSynFamilyTyCon tc; _ -> False }, ppr orig_ct )
-        do { writeMetaTyVar tv ty_lhs
-           ; let evterm = EvCoercion (mkTcNomReflCo ty_lhs)
-                 evvar  = ctev_evar (cc_ev zct)
-           ; when (isWantedCt orig_ct) $         -- Can be derived (Trac #8129)
-             addTcEvBind binds_var evvar evterm
-           ; traceTc "zonkFlats/unflattening" $
-             vcat [ text "zct = " <+> ppr zct,
-                    text "binds_var = " <+> ppr binds_var ]
-           ; return Nothing }
-      | otherwise
-      = return (Just zct)
 \end{code}
 
-Note [Unflattening while zonking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A bunch of wanted constraints could contain wanted equations of the form
-(F taus ~ alpha) where alpha is either an ordinary unification variable, or
-a flatten unification variable.
-
-These are ordinary wanted constraints and can/should be solved by
-ordinary unification alpha := F taus. However the constraint solving
-algorithm does not do that, as their 'inert' form is F taus ~ alpha.
-
-Hence, we need an extra step to 'unflatten' these equations by
-performing unification. This unification, if it happens at the end of
-constraint solving, cannot produce any more interactions in the
-constraint solver so it is safe to do it as the very very last step.
-
-We choose therefore to do it during zonking, in the function
-zonkFlats. This is in analogy to the zonking of given "flatten skolems"
-which are eliminated in favor of the underlying type that they are
-equal to.
-
-Note that, because we now have to affect *evidence* while zonking
-(setting some evidence binds to identities), we have to pass to the
-zonkWC function an evidence variable to collect all the extra
-variables.
-
-Note [How to unflatten]
-~~~~~~~~~~~~~~~~~~~~~~~
-How do we unflatten during zonking.  Consider a bunch of flat constraints.
-Consider them one by one.  For each such constraint C
-  * Zonk C (to apply current substitution)
-  * If C is of form F tys ~ alpha,
-       where alpha is touchable
-       and   alpha is not mentioned in tys
-    then unify alpha := F tys
-         and discard C
-
-After processing all the flat constraints, zonk them again to propagate
-the inforamtion from later ones to earlier ones.  Eg
-  Start:  (F alpha ~ beta, G Int ~ alpha)
-  Then we get beta := F alpha
-              alpha := G Int
-  but we must apply the second unification to the first constraint.
-
-
 \begin{code}
-zonkCts :: Cts -> TcM Cts
-zonkCts = mapBagM zonkCt
+zonkFlats :: Cts -> TcM Cts
+zonkFlats cts = do { cts' <- mapBagM zonkCt' cts
+                   ; traceTc "zonkFlats done:" (ppr cts')
+                   ; return cts' }
+
+zonkCt' :: Ct -> TcM Ct
+zonkCt' ct = zonkCt ct
 
 zonkCt :: Ct -> TcM Ct
 zonkCt ct@(CHoleCan { cc_ev = ev })
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 7e80906254..cf1e851ed3 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -44,8 +44,8 @@ module TcRnTypes(
         ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
 
         -- Canonical constraints
-        Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, dropDerivedWC,
-        singleCt, listToCts, ctsElts, extendCts, extendCtsList,
+        Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts,
+        singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
         isEmptyCts, isCTyEqCan, isCFunEqCan,
         isCDictCan_Maybe, isCFunEqCan_maybe,
         isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
@@ -56,6 +56,7 @@ module TcRnTypes(
 
         WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
         andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols,
+        dropDerivedWC,
 
         Implication(..),
         SubGoalCounter(..),
@@ -72,10 +73,9 @@ module TcRnTypes(
         CtEvidence(..),
         mkGivenLoc,
         isWanted, isGiven, isDerived,
-        canRewrite, canRewriteOrSame,
 
         -- Pretty printing
-        pprEvVarTheta, pprWantedsWithLocs,
+        pprEvVarTheta, 
         pprEvVars, pprEvVarWithType,
         pprArising, pprArisingAt,
 
@@ -984,9 +984,9 @@ type Cts = Bag Ct
 data Ct
   -- Atomic canonical constraints
   = CDictCan {  -- e.g.  Num xi
-      cc_ev :: CtEvidence,   -- See Note [Ct/evidence invariant]
+      cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]
       cc_class  :: Class,
-      cc_tyargs :: [Xi]
+      cc_tyargs :: [Xi]        -- cc_tyargs are function-free, hence Xi
     }
 
   | CIrredEvCan {  -- These stand for yet-unusable predicates
@@ -998,26 +998,43 @@ data Ct
         -- See Note [CIrredEvCan constraints]
     }
 
-  | CTyEqCan {  -- tv ~ xi      (recall xi means function free)
-       -- Invariant:
+  | CTyEqCan {  -- tv ~ rhs
+       -- Invariants:
+       --   * See Note [Applying the inert substitution] in TcFlatten
        --   * tv not in tvs(xi)   (occurs check)
-       --   * typeKind xi `subKind` typeKind tv
+       --   * If tv is a TauTv, then rhs has no foralls
+       --       (this avoids substituting a forall for the tyvar in other types)
+       --   * typeKind ty `subKind` typeKind tv
        --       See Note [Kind orientation for CTyEqCan]
-       --   * We prefer unification variables on the left *JUST* for efficiency
-      cc_ev :: CtEvidence,    -- See Note [Ct/evidence invariant]
+       --   * rhs is not necessarily function-free,
+       --       but it has no top-level function.
+       --     E.g. a ~ [F b]  is fine
+       --     but  a ~ F b    is not
+       --   * If rhs is also a tv, then it is oriented to give best chance of
+       --     unification happening; eg if rhs is touchable then lhs is too
+      cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]
       cc_tyvar  :: TcTyVar,
-      cc_rhs    :: Xi
+      cc_rhs    :: TcType      -- Not necessarily function-free (hence not Xi)
+                               -- See invariants above
     }
 
-  | CFunEqCan {  -- F xis ~ xi
-       -- Invariant: * isSynFamilyTyCon cc_fun
-       --            * typeKind (F xis) `subKind` typeKind xi
-       --       See Note [Kind orientation for CFunEqCan]
+  | CFunEqCan {  -- F xis ~ fsk
+       -- Invariants:
+       --   * isSynFamilyTyCon cc_fun
+       --   * typeKind (F xis) = tyVarKind fsk
+       --   * always Nominal role
+       --   * always Given or Wanted, never Derived
       cc_ev     :: CtEvidence,  -- See Note [Ct/evidence invariant]
       cc_fun    :: TyCon,       -- A type function
-      cc_tyargs :: [Xi],        -- Either under-saturated or exactly saturated
-      cc_rhs    :: Xi           --    *never* over-saturated (because if so
-                                --    we should have decomposed)
+
+      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  -- [Given]  always a FlatSkol skolem
+                            -- [Wanted] always a FlatMetaTv unification variable
+        -- See Note [The flattening story] in TcFlatten
     }
 
   | CNonCanonical {        -- See Note [NonCanonical Semantics]
@@ -1033,11 +1050,13 @@ data Ct
 
 Note [Kind orientation for CTyEqCan]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given an equality  (t:* ~ s:Open), we absolutely want to re-orient it.
-We can't solve it by updating t:=s, ragardless of how touchable 't' is,
-because the kinds don't work.  Indeed we don't want to leave it with
-the orientation (t ~ s), because if that gets into the inert set we'll
-start replacing t's by s's, and that too is the wrong way round.
+Given an equality (t:* ~ s:Open), we can't solve it by updating t:=s,
+ragardless of how touchable 't' is, because the kinds don't work.
+
+Instead we absolutely must re-orient it. Reason: if that gets into the
+inert set we'll start replacing t's by s's, and that might make a
+kind-correct type into a kind error.  After re-orienting,
+we may be able to solve by updating s:=t.
 
 Hence in a CTyEqCan, (t:k1 ~ xi:k2) we require that k2 is a subkind of k1.
 
@@ -1144,7 +1163,7 @@ comprehensible error.  Particularly:
 
  * Insoluble derived wanted equalities (e.g. [D] Int ~ Bool) may
    arise from functional dependency interactions.  We are careful
-   to keep a good CtOrigin on such constriants (FunDepOrigin1, FunDepOrigin2)
+   to keep a good CtOrigin on such constraints (FunDepOrigin1, FunDepOrigin2)
    so that we can produce a good error message (Trac #9612)
 
 Since we leave these Derived constraints in the residual WantedConstraints,
@@ -1225,8 +1244,11 @@ listToCts = listToBag
 ctsElts :: Cts -> [Ct]
 ctsElts = bagToList
 
-extendCts :: Cts -> Ct -> Cts
-extendCts = snocBag
+consCts :: Ct -> Cts -> Cts
+consCts = consBag
+
+snocCts :: Cts -> Ct -> Cts
+snocCts = snocBag
 
 extendCtsList :: Cts -> [Ct] -> Cts
 extendCtsList cts xs | null xs   = cts
@@ -1240,6 +1262,9 @@ emptyCts = emptyBag
 
 isEmptyCts :: Cts -> Bool
 isEmptyCts = isEmptyBag
+
+pprCts :: Cts -> SDoc
+pprCts cts = vcat (map ppr (bagToList cts))
 \end{code}
 
 %************************************************************************
@@ -1303,15 +1328,15 @@ addInsols wc cts
 instance Outputable WantedConstraints where
   ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n})
    = ptext (sLit "WC") <+> braces (vcat
-        [ if isEmptyBag f then empty else
-          ptext (sLit "wc_flat =")  <+> pprBag ppr f
-        , if isEmptyBag i then empty else
-          ptext (sLit "wc_impl =")  <+> pprBag ppr i
-        , if isEmptyBag n then empty else
-          ptext (sLit "wc_insol =") <+> pprBag ppr n ])
-
-pprBag :: (a -> SDoc) -> Bag a -> SDoc
-pprBag pp b = foldrBag (($$) . pp) empty b
+        [ ppr_bag (ptext (sLit "wc_flat")) f
+        , ppr_bag (ptext (sLit "wc_insol")) n
+        , ppr_bag (ptext (sLit "wc_impl")) i ])
+
+ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc
+ppr_bag doc bag
+ | isEmptyBag bag = empty
+ | otherwise      = hang (doc <+> equals) 
+                       2 (foldrBag (($$) . ppr) empty bag)
 \end{code}
 
 
@@ -1335,10 +1360,6 @@ data Implication
                                  --   (order does not matter)
                                  -- See Invariant (GivenInv) in TcType
 
-      ic_fsks  :: [TcTyVar],     -- Extra flatten-skolems introduced by
-                                 -- by flattening the givens
-                                 -- See Note [Given flatten-skolems]
-
       ic_no_eqs :: Bool,         -- True  <=> ic_givens have no equalities, for sure
                                  -- False <=> ic_givens might have equalities
 
@@ -1354,19 +1375,19 @@ data Implication
     }
 
 instance Outputable Implication where
-  ppr (Implic { ic_untch = untch, ic_skols = skols, ic_fsks = fsks
+  ppr (Implic { ic_untch = untch, ic_skols = skols
               , ic_given = given, ic_no_eqs = no_eqs
-              , ic_wanted = wanted
+              , ic_wanted = wanted, ic_insol = insol
               , ic_binds = binds, ic_info = info })
-   = ptext (sLit "Implic") <+> braces
-     (sep [ ptext (sLit "Untouchables =") <+> ppr untch
-          , ptext (sLit "Skolems =") <+> pprTvBndrs skols
-          , ptext (sLit "Flatten-skolems =") <+> pprTvBndrs fsks
-          , ptext (sLit "No-eqs =") <+> ppr no_eqs
-          , ptext (sLit "Given =") <+> pprEvVars given
-          , ptext (sLit "Wanted =") <+> ppr wanted
-          , ptext (sLit "Binds =") <+> ppr binds
-          , pprSkolInfo info ])
+   = hang (ptext (sLit "Implic") <+> lbrace)
+        2 (sep [ ptext (sLit "Untouchables =") <+> ppr untch
+               , ptext (sLit "Skolems =") <+> pprTvBndrs skols
+               , ptext (sLit "No-eqs =") <+> ppr no_eqs
+               , ptext (sLit "Insol =") <+> ppr insol
+               , hang (ptext (sLit "Given ="))  2 (pprEvVars given)
+               , hang (ptext (sLit "Wanted =")) 2 (ppr wanted)
+               , ptext (sLit "Binds =") <+> ppr binds
+               , pprSkolInfo info ] <+> rbrace)
 \end{code}
 
 Note [Shadowing in a constraint]
@@ -1437,12 +1458,6 @@ pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)
 
 pprEvVarWithType :: EvVar -> SDoc
 pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v)
-
-pprWantedsWithLocs :: WantedConstraints -> SDoc
-pprWantedsWithLocs wcs
-  =  vcat [ pprBag ppr (wc_flat wcs)
-          , pprBag ppr (wc_impl wcs)
-          , pprBag ppr (wc_insol wcs) ]
 \end{code}
 
 %************************************************************************
@@ -1524,49 +1539,8 @@ isGiven _ = False
 isDerived :: CtEvidence -> Bool
 isDerived (CtDerived {}) = True
 isDerived _              = False
-
------------------------------------------
-canRewrite :: CtEvidence -> CtEvidence -> Bool
--- Very important function!
--- See Note [canRewrite and canRewriteOrSame]
-canRewrite (CtGiven {})   _              = True
-canRewrite (CtWanted {})  (CtDerived {}) = True
-canRewrite (CtDerived {}) (CtDerived {}) = True  -- Derived can't solve wanted/given
-canRewrite _ _ = False             -- No evidence for a derived, anyway
-
-canRewriteOrSame :: CtEvidence -> CtEvidence -> Bool
-canRewriteOrSame (CtGiven {})   _              = True
-canRewriteOrSame (CtWanted {})  (CtWanted {})  = True
-canRewriteOrSame (CtWanted {})  (CtDerived {}) = True
-canRewriteOrSame (CtDerived {}) (CtDerived {}) = True
-canRewriteOrSame _ _ = False
 \end{code}
 
-See Note [canRewrite and canRewriteOrSame]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-(canRewrite ct1 ct2) holds if the constraint ct1 can be used to solve ct2.
-"To solve" means a reaction where the active parts of the two constraints match.
-   active(F xis ~ xi) = F xis
-   active(tv ~ xi)    = tv
-   active(D xis)      = D xis
-   active(IP nm ty)   = nm
-
-At the moment we don't allow Wanteds to rewrite Wanteds, because that can give
-rise to very confusing type error messages.  A good example is Trac #8450.
-Here's another
-   f :: a -> Bool
-   f x = ( [x,'c'], [x,True] ) `seq` True
-Here we get
-  [W] a ~ Char
-  [W] a ~ Bool
-but we do not want to complain about Bool ~ Char!
-
-NB:  either (a `canRewrite` b) or (b `canRewrite` a)
-         or a==b
-     must hold
-
-canRewriteOrSame is similar but returns True for Wanted/Wanted.
-See the call sites for explanations.
 
 %************************************************************************
 %*                                                                      *
@@ -1690,11 +1664,13 @@ data CtLoc = CtLoc { ctl_origin :: CtOrigin
   --    source location:  tcl_loc   :: SrcSpan
   --    context:          tcl_ctxt  :: [ErrCtxt]
   --    binder stack:     tcl_bndrs :: [TcIdBinders]
+  --    level:            tcl_untch :: Untouchables
 
-mkGivenLoc :: SkolemInfo -> TcLclEnv -> CtLoc
-mkGivenLoc skol_info env = CtLoc { ctl_origin = GivenOrigin skol_info
-                                 , ctl_env = env
-                                 , ctl_depth = initialSubGoalDepth }
+mkGivenLoc :: Untouchables -> SkolemInfo -> TcLclEnv -> CtLoc
+mkGivenLoc untch skol_info env 
+  = CtLoc { ctl_origin = GivenOrigin skol_info
+          , ctl_env    = env { tcl_untch = untch }
+          , ctl_depth  = initialSubGoalDepth }
 
 ctLocEnv :: CtLoc -> TcLclEnv
 ctLocEnv = ctl_env
@@ -1837,9 +1813,6 @@ pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "Unk
 \begin{code}
 data CtOrigin
   = GivenOrigin SkolemInfo
-  | FlatSkolOrigin              -- Flatten-skolems created for Givens
-                                -- Note [When does an implication have given equalities?]
-                                -- in TcSimplify
 
   -- All the others are for *wanted* constraints
   | OccurrenceOf Name           -- Occurrence of an overloaded identifier
@@ -1898,7 +1871,6 @@ data CtOrigin
   | UnboundOccurrenceOf RdrName
   | ListOrigin          -- An overloaded list
 
-
 ctoHerald :: SDoc
 ctoHerald = ptext (sLit "arising from")
 
@@ -1949,7 +1921,6 @@ pprCtOrigin simple_origin
 
 ----------------
 pprCtO :: CtOrigin -> SDoc  -- Ones that are short one-liners
-pprCtO FlatSkolOrigin        = ptext (sLit "a given flatten-skolem")
 pprCtO (OccurrenceOf name)   = hsep [ptext (sLit "a use of"), quotes (ppr name)]
 pprCtO AppOrigin             = ptext (sLit "an application")
 pprCtO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)]
diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs
index 3b405b3dda..f1d528f098 100644
--- a/compiler/typecheck/TcRules.lhs
+++ b/compiler/typecheck/TcRules.lhs
@@ -168,7 +168,6 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
        ; rhs_binds_var <- newTcEvBinds
        ; emitImplication $ Implic { ic_untch  = noUntouchables
                                   , ic_skols  = qtkvs
-                                  , ic_fsks   = []
                                   , ic_no_eqs = False
                                   , ic_given  = lhs_evs
                                   , ic_wanted = rhs_wanted
@@ -183,7 +182,6 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
        ; lhs_binds_var <- newTcEvBinds
        ; emitImplication $ Implic { ic_untch  = noUntouchables
                                   , ic_skols  = qtkvs
-                                  , ic_fsks   = []
                                   , ic_no_eqs = False
                                   , ic_given  = lhs_evs
                                   , ic_wanted = other_lhs_wanted
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 034c7a8edc..4d910d9d3b 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -7,32 +7,30 @@ module TcSMonad (
        -- Canonical constraints, definition is now in TcRnTypes
 
     WorkList(..), isEmptyWorkList, emptyWorkList,
-    workListFromEq, workListFromNonEq, workListFromCt,
-    extendWorkListEq, extendWorkListFunEq,
+    extendWorkListFunEq,
     extendWorkListNonEq, extendWorkListCt,
-    extendWorkListCts, extendWorkListEqs, appendWorkList, selectWorkItem,
-    withWorkList, workListSize,
+    extendWorkListCts, appendWorkList, selectWorkItem,
+    workListSize,
 
-    updWorkListTcS, updWorkListTcS_return,
+    updWorkListTcS, updWorkListTcS_return, getWorkListImplics,
 
-    updTcSImplics,
+    updInertCans, updInertDicts, updInertIrreds, updInertFunEqs,
 
     Ct(..), Xi, tyVarsOfCt, tyVarsOfCts,
-    emitInsoluble,
+    emitInsoluble, emitWorkNC,
 
     isWanted, isDerived,
     isGivenCt, isWantedCt, isDerivedCt,
 
-    canRewrite,
     mkGivenLoc,
 
     TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality
-    traceFireTcS, bumpStepCountTcS,
+    traceFireTcS, bumpStepCountTcS, csTraceTcS,
     tryTcS, nestTcS, nestImplicTcS, recoverTcS,
     wrapErrTcS, wrapWarnTcS,
 
     -- Getting and setting the flattening cache
-    addSolvedDict, addSolvedFunEq, getGivenInfo,
+    addSolvedDict, 
 
     -- Marking stuff as used
     addUsedRdrNamesTcS,
@@ -41,14 +39,18 @@ module TcSMonad (
 
     setEvBind,
     XEvTerm(..),
-    MaybeNew (..), isFresh, freshGoal, freshGoals, getEvTerm, getEvTerms,
+    Freshness(..), freshGoals, 
+
+    StopOrContinue(..), continueWith, stopWith, andWhenContinue,
 
     xCtEvidence,        -- Transform a CtEvidence during a step
     rewriteEvidence,    -- Specialized version of xCtEvidence for coercions
     rewriteEqEvidence,  -- Yet more specialised, for equality coercions
     maybeSym,
 
-    newWantedEvVar, newWantedEvVarNC, newWantedEvVarNonrec, newDerived,
+    newTcEvBinds, newWantedEvVar, newWantedEvVarNC, newWantedEvVarNonrec, 
+    newEvVar, newGivenEvVar, newDerived, 
+    emitNewDerived, emitNewDerivedEq,
     instDFunConstraints,
 
        -- Creation of evidence variables
@@ -56,37 +58,40 @@ module TcSMonad (
 
     getInstEnvs, getFamInstEnvs,                -- Getting the environments
     getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
-    getTcEvBindsMap, getTcSTyBindsMap,
+    getTcEvBindsMap, 
 
-    lookupFlatEqn, newFlattenSkolem,            -- Flatten skolems
+    lookupFlatCache, newFlattenSkolem,            -- Flatten skolems
 
         -- Deque
     Deque(..), insertDeque, emptyDeque,
 
         -- Inerts
     InertSet(..), InertCans(..),
-    getInertEqs,
-    emptyInert, getTcSInerts, setTcSInerts,
-    getInertUnsolved, checkAllSolved,
+    getNoGivenEqs, setInertCans, getInertEqs, getInertCans,
+    emptyInert, getTcSInerts, setTcSInerts, 
+    getUnsolvedInerts, checkAllSolved,
     prepareInertsForImplications,
-    addInertCan, insertInertItemTcS,
+    addInertCan, insertInertItemTcS, insertFunEq,
     EqualCtList,
     lookupSolvedDict, extendFlatCache,
 
-    findFunEq, findTyEqs,
     findDict, findDictsByClass, addDict, addDictsByClass, delDict, partitionDicts,
-    findFunEqsByTyCon, findFunEqs, addFunEq, replaceFunEqs, partitionFunEqs,
+
+    findFunEq, findTyEqs, 
+    findFunEqsByTyCon, findFunEqs, partitionFunEqs,
+    sizeFunEqMap,
 
     instDFunType,                              -- Instantiation
     newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS,
-    cloneMetaTyVar,
+    cloneMetaTyVar, demoteUnfilledFmv,
 
-    Untouchables, isTouchableMetaTyVarTcS, isFilledMetaTyVar_maybe,
-    zonkTyVarsAndFV,
+    Untouchables, isTouchableMetaTyVarTcS,
+    isFilledMetaTyVar_maybe, isFilledMetaTyVar,
+    zonkTyVarsAndFV, zonkTcType, zonkTcTyVar, zonkFlats,
 
     getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
 
-    matchFam, 
+    matchFam,
     checkWellStagedDFun,
     pprEq                                    -- Smaller utils, re-exported from TcM
                                              -- TODO (DV): these are only really used in the
@@ -122,11 +127,10 @@ import Name
 import RdrName (RdrName, GlobalRdrEnv)
 import RnEnv (addUsedRdrNames)
 import Var
-import VarSet
 import VarEnv
+import VarSet
 import Outputable
 import Bag
-import MonadUtils
 import UniqSupply
 
 import FastString
@@ -137,13 +141,13 @@ import TcRnTypes
 import BasicTypes
 import Unique
 import UniqFM
-import Maybes ( orElse, catMaybes, firstJusts )
-import Pair ( pSnd )
+import Maybes ( orElse, firstJusts )
 
 import TrieMap
-import Control.Monad( ap, when )
+import Control.Monad( ap, when, unless )
+import MonadUtils
 import Data.IORef
-import Data.List( partition )
+import Pair
 
 #ifdef DEBUG
 import Digraph
@@ -172,26 +176,15 @@ is not strictly necessary. Notice that non-canonical constraints
 are also parts of the worklist.
 
 
-Note [NonCanonical Semantics]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Note that canonical constraints involve a CNonCanonical constructor. In the worklist
-we use this constructor for constraints that have not yet been canonicalized such as
-   [Int] ~ [a]
-In other words, all constraints start life as NonCanonicals.
-
-On the other hand, in the Inert Set (see below) the presence of a NonCanonical somewhere
-means that we have a ``frozen error''.
-
-NonCanonical constraints never interact directly with other constraints -- but they can
-be rewritten by equalities (for instance if a non canonical exists in the inert, we'd
-better rewrite it as much as possible before reporting it as an error to the user)
-
 \begin{code}
 data Deque a = DQ [a] [a]   -- Insert in RH field, remove from LH field
                             -- First to remove is at head of LH field
 
 instance Outputable a => Outputable (Deque a) where
-  ppr (DQ as bs) = ppr (as ++ reverse bs)   -- Show first one to come out at the start
+  ppr q = ppr (dequeList q)
+
+dequeList :: Deque a -> [a]
+dequeList (DQ as bs) = as ++ reverse bs  -- First one to come out at the start
 
 emptyDeque :: Deque a
 emptyDeque = DQ [] []
@@ -216,75 +209,72 @@ extractDeque (DQ [] bs)     = case reverse bs of
                                 [] -> panic "extractDeque"
 
 -- See Note [WorkList priorities]
-data WorkList = WorkList { wl_eqs    :: [Ct]
-                         , wl_funeqs :: Deque Ct
-                         , wl_rest   :: [Ct]
-                         }
-
+data WorkList 
+  = WL { wl_eqs     :: [Ct]
+       , wl_funeqs  :: Deque Ct
+       , wl_rest    :: [Ct]
+       , wl_implics :: Bag Implication  -- See Note [Residual implications]
+    }
 
 appendWorkList :: WorkList -> WorkList -> WorkList
-appendWorkList new_wl orig_wl
-   = WorkList { wl_eqs    = wl_eqs new_wl    ++            wl_eqs orig_wl
-              , wl_funeqs = wl_funeqs new_wl `appendDeque` wl_funeqs orig_wl
-              , wl_rest   = wl_rest new_wl   ++            wl_rest orig_wl }
+appendWorkList 
+    (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1, wl_implics = implics1 })
+    (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2, wl_implics = implics2 })
+   = WL { wl_eqs     = eqs1     ++            eqs2
+        , wl_funeqs  = funeqs1  `appendDeque` funeqs2
+        , wl_rest    = rest1    ++            rest2
+        , wl_implics = implics1 `unionBags`   implics2 }
 
 
 workListSize :: WorkList -> Int
-workListSize (WorkList { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })
+workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })
   = length eqs + dequeSize funeqs + length rest
 
 extendWorkListEq :: Ct -> WorkList -> WorkList
--- Extension by equality
-extendWorkListEq ct wl
-  | Just {} <- isCFunEqCan_maybe ct
-  = extendWorkListFunEq ct wl
-  | otherwise
+extendWorkListEq ct wl 
   = wl { wl_eqs = ct : wl_eqs wl }
 
 extendWorkListFunEq :: Ct -> WorkList -> WorkList
 extendWorkListFunEq ct wl
   = wl { wl_funeqs = insertDeque ct (wl_funeqs wl) }
 
-extendWorkListEqs :: [Ct] -> WorkList -> WorkList
--- Append a list of equalities
-extendWorkListEqs cts wl = foldr extendWorkListEq wl cts
-
 extendWorkListNonEq :: Ct -> WorkList -> WorkList
 -- Extension by non equality
 extendWorkListNonEq ct wl
   = wl { wl_rest = ct : wl_rest wl }
 
+extendWorkListImplic :: Implication -> WorkList -> WorkList
+extendWorkListImplic implic wl
+  = wl { wl_implics = implic `consBag` wl_implics wl }
+
 extendWorkListCt :: Ct -> WorkList -> WorkList
 -- Agnostic
 extendWorkListCt ct wl
- | isEqPred (ctPred ct) = extendWorkListEq ct wl
- | otherwise = extendWorkListNonEq ct wl
+ = case classifyPredType (ctPred ct) of
+     EqPred ty1 _
+       | Just (tc,_) <- tcSplitTyConApp_maybe ty1
+       , isSynFamilyTyCon tc
+       -> extendWorkListFunEq ct wl
+       | otherwise
+       -> extendWorkListEq ct wl
+
+     _ -> extendWorkListNonEq ct wl
 
 extendWorkListCts :: [Ct] -> WorkList -> WorkList
 -- Agnostic
 extendWorkListCts cts wl = foldr extendWorkListCt wl cts
 
 isEmptyWorkList :: WorkList -> Bool
-isEmptyWorkList wl
-  = null (wl_eqs wl) &&  null (wl_rest wl) && isEmptyDeque (wl_funeqs wl)
+isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs
+                    , wl_rest = rest, wl_implics = implics })
+  = null eqs && null rest && isEmptyDeque funeqs && isEmptyBag implics
 
 emptyWorkList :: WorkList
-emptyWorkList = WorkList { wl_eqs  = [], wl_rest = [], wl_funeqs = emptyDeque }
-
-workListFromEq :: Ct -> WorkList
-workListFromEq ct = extendWorkListEq ct emptyWorkList
-
-workListFromNonEq :: Ct -> WorkList
-workListFromNonEq ct = extendWorkListNonEq ct emptyWorkList
-
-workListFromCt :: Ct -> WorkList
--- Agnostic
-workListFromCt ct | isEqPred (ctPred ct) = workListFromEq ct
-                  | otherwise            = workListFromNonEq ct
-
+emptyWorkList = WL { wl_eqs  = [], wl_rest = []
+                   , wl_funeqs = emptyDeque, wl_implics = emptyBag }
 
 selectWorkItem :: WorkList -> (Maybe Ct, WorkList)
-selectWorkItem wl@(WorkList { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest })
+selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest })
   = case (eqs,feqs,rest) of
       (ct:cts,_,_)     -> (Just ct, wl { wl_eqs    = cts })
       (_,fun_eqs,_)    | Just (fun_eqs', ct) <- extractDeque fun_eqs
@@ -294,10 +284,18 @@ selectWorkItem wl@(WorkList { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest })
 
 -- Pretty printing
 instance Outputable WorkList where
-  ppr wl = vcat [ text "WorkList (eqs)   = " <+> ppr (wl_eqs wl)
-                , text "WorkList (funeqs)= " <+> ppr (wl_funeqs wl)
-                , text "WorkList (rest)  = " <+> ppr (wl_rest wl)
-                ]
+  ppr (WL { wl_eqs = eqs, wl_funeqs = feqs
+          , wl_rest = rest, wl_implics = implics })
+   = text "WL" <+> (braces $
+     vcat [ ppUnless (null eqs) $ 
+            ptext (sLit "Eqs =") <+> vcat (map ppr eqs)
+          , ppUnless (isEmptyDeque feqs) $
+            ptext (sLit "Funeqs =") <+> vcat (map ppr (dequeList feqs))
+          , ppUnless (null rest) $
+            ptext (sLit "Eqs =") <+> vcat (map ppr rest)
+          , ppUnless (isEmptyBag implics) $
+            ptext (sLit "Implics =") <+> vcat (map ppr (bagToList implics))
+          ])
 \end{code}
 
 %************************************************************************
@@ -335,14 +333,14 @@ The InertCans represents a collection of constraints with the following properti
          apply the substitution /recursively/ to the types
          involved. Currently the one AND ONLY way in the whole
          constraint solver that we rewrite types and constraints wrt
-         to the inert substitution is TcCanonical/flattenTyVar.
+         to the inert substitution is TcFlatten/flattenTyVar.
 
        - In the past we did try to have the inert substitution as
          idempotent as possible but this would only be true for
          constraints of the same flavor, so in total the inert
          substitution could not be idempotent, due to flavor-related
-         issued.  Note [Non-idempotent inert substitution] explains
-         what is going on.
+         issued.  Note [Non-idempotent inert substitution] in TcFlatten
+         explains what is going on.
 
        - Whenever a constraint ends up in the worklist we do
          recursively apply exhaustively the inert substitution to it
@@ -356,29 +354,9 @@ The InertCans represents a collection of constraints with the following properti
          equalities can safely stay in the inert set and which must be
          kicked out to be rewritten and re-checked for occurs errors.
 
-
-Note [Solved constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-When we take a step to simplify a constraint 'c', we call the original constraint "solved".
-For example:   Wanted:    ev  :: [s] ~ [t]
-               New goal:  ev1 :: s ~ t
-               Then 'ev' is now "solved".
-
-The reason for all this is simply to avoid re-solving goals we have solved already.
-
-* A solved Wanted may depend on as-yet-unsolved goals, so (for example) we should not
-  use it to rewrite a Given; in that sense the solved goal is still a Wanted
-
-* A solved Given is just given
-
-* A solved Derived in inert_solved is possible; purpose is to avoid
-  creating tons of identical Derived goals.
-
-  But there are no solved Deriveds in inert_solved_funeqs
-
 Note [Type family equations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Type-family equations, of form (ev : F tys ~ ty), live in four places
+Type-family equations, of form (ev : F tys ~ ty), live in three places
 
   * The work-list, of course
 
@@ -393,12 +371,8 @@ Type-family equations, of form (ev : F tys ~ ty), live in four places
     a top-level goal.  Eg in the above example we don't want to solve w3
     using w3 itself!
 
-  * The inert_solved_funeqs.  These are all "solved" goals (see Note [Solved constraints]),
-    the result of using a top-level type-family instance.
-
   * The inert_funeqs are un-solved but fully processed and in the InertCans.
 
-
 \begin{code}
 -- All Given (fully known) or Wanted or Derived
 -- See Note [Detailed InertCans Invariants] for more
@@ -408,7 +382,7 @@ data InertCans
               -- Some Refl equalities are also in tcs_ty_binds
               -- see Note [Spontaneously solved in TyBinds] in TcInteract
 
-       , inert_funeqs :: FunEqMap EqualCtList
+       , inert_funeqs :: FunEqMap Ct
               -- All CFunEqCans; index is the whole family head type.
 
        , inert_dicts :: DictMap Ct
@@ -421,13 +395,6 @@ data InertCans
 
        , inert_insols :: Cts
               -- Frozen errors (as non-canonicals)
-
-       , inert_no_eqs :: !Bool    
-              -- Set to False when adding a new equality
-              -- (eq/funeq) or potential equality (irred)
-              -- whose evidence is not a constant
-              -- See Note [When does an implication have given equalities?]
-              -- in TcSimplify
        }
 
 type EqualCtList = [Ct]
@@ -448,8 +415,10 @@ data InertSet
               -- Canonical Given, Wanted, Derived (no Solved)
               -- Sometimes called "the inert set"
 
-       , inert_flat_cache :: FunEqMap (CtEvidence, TcType)
+       , inert_flat_cache :: FunEqMap (TcCoercion, TcTyVar)
               -- See Note [Type family equations]
+              -- If    F tys :-> (co, fsk), 
+              -- then  co :: F tys ~ fsk
               -- 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
@@ -457,17 +426,6 @@ data InertSet
               -- when allocating a new flatten-skolem.
               -- Not necessarily inert wrt top-level equations (or inert_cans)
 
-       , inert_fsks :: [TcTyVar]  -- Rigid flatten-skolems (arising from givens)
-                                  -- allocated in this local scope
-                                  -- See Note [Given flatten-skolems]
-
-       , inert_solved_funeqs :: FunEqMap (CtEvidence, TcType)
-              -- See Note [Type family equations]
-              -- Of form co :: F xis ~ xi
-              -- Always the result of using a top-level family axiom F xis ~ tau
-              -- No Deriveds
-              -- Not necessarily fully rewritten (by type substitutions)
-
        , inert_solved_dicts   :: DictMap CtEvidence
               -- Of form ev :: C t1 .. tn
               -- Always the result of using a top-level instance declaration
@@ -479,33 +437,12 @@ data InertSet
        }
 \end{code}
 
-Note [Given flatten-skolems]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we simplify the implication
-    forall b. C (F a) b => (C (F a) beta, blah)
-We'll flatten the givens, introducing a flatten-skolem, so the
-givens effectively look like
-    (C fsk b, F a ~ fsk)
-Then we simplify the wanteds, transforming (C (F a) beta) to (C fsk beta).
-Now, if we don't solve that wanted, we'll put it back into the residual
-implication.  But where is fsk bound?
-
-We solve this by recording the given flatten-skolems in the implication
-(the ic_fsks field), so it's as if we change the implication to
-    forall b, fsk. (C fsk b, F a ~ fsk) => (C fsk beta, blah)
-
-We don't need to explicitly record the (F a ~ fsk) constraint in the implication
-because we can recover it from inside the fsk TyVar itself.  But we do need
-to treat that (F a ~ fsk) as a new given.  See the fsk_bag stuff in
-TcInteract.solveInteractGiven.
-
 \begin{code}
 instance Outputable InertCans where
   ppr ics = vcat [ ptext (sLit "Equalities:")
                    <+> vcat (map ppr (varEnvElts (inert_eqs ics)))
                  , ptext (sLit "Type-function equalities:")
                    <+> vcat (map ppr (funEqsToList (inert_funeqs ics)))
-                 , ptext (sLit "No-eqs:") <+> ppr (inert_no_eqs ics)
                  , ptext (sLit "Dictionaries:")
                    <+> vcat (map ppr (Bag.bagToList $ dictsToBag (inert_dicts ics)))
                  , ptext (sLit "Irreds:")
@@ -516,8 +453,7 @@ instance Outputable InertCans where
 
 instance Outputable InertSet where
   ppr is = vcat [ ppr $ inert_cans is
-                , text "Solved dicts"  <+> int (sizeDictMap (inert_solved_dicts is))
-                , text "Solved funeqs" <+> int (sizeFunEqMap (inert_solved_funeqs is))]
+                , text "Solved dicts"  <+> int (sizeDictMap (inert_solved_dicts is)) ]
 
 emptyInert :: InertSet
 emptyInert
@@ -526,31 +462,23 @@ emptyInert
                          , inert_funeqs  = emptyFunEqs
                          , inert_irreds  = emptyCts
                          , inert_insols  = emptyCts
-                         , inert_no_eqs  = True  -- See Note [inert_fsks and inert_no_eqs]
                          }
-       , inert_fsks          = []  -- See Note [inert_fsks and inert_no_eqs]
        , inert_flat_cache    = emptyFunEqs
-       , inert_solved_funeqs = emptyFunEqs
        , inert_solved_dicts  = emptyDictMap }
 
 ---------------
 addInertCan :: InertCans -> Ct -> InertCans
 -- Precondition: item /is/ canonical
-addInertCan ics item@(CTyEqCan { cc_ev = ev })
+addInertCan ics item@(CTyEqCan {})
   = ics { inert_eqs = extendVarEnv_C (\eqs _ -> item : eqs)
                               (inert_eqs ics)
-                              (cc_tyvar item) [item]
-        , inert_no_eqs = isFlatSkolEv ev && inert_no_eqs ics }
-    -- See Note [When does an implication have given equalities?] in TcSimplify
+                              (cc_tyvar item) [item] }
 
-addInertCan ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys, cc_ev = ev })
-  = ics { inert_funeqs = addFunEq (inert_funeqs ics) tc tys item
-        , inert_no_eqs = isFlatSkolEv ev && inert_no_eqs ics }
-    -- See Note [When does an implication have given equalities?] in TcSimplify
+addInertCan ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })
+  = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item }
 
 addInertCan ics item@(CIrredEvCan {})
-  = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item
-        , inert_no_eqs = False }
+  = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item }
        -- The 'False' is because the irreducible constraint might later instantiate
        -- to an equality.
        -- But since we try to simplify first, if there's a constraint function FC with
@@ -565,14 +493,6 @@ addInertCan _ item
     ppr item   -- Can't be CNonCanonical, CHoleCan,
                -- because they only land in inert_insols
 
-isFlatSkolEv :: CtEvidence -> Bool
--- True if (a) it's a Given and (b) it is evidence for
--- (or derived from) a flatten-skolem equality.
--- See Note [When does an implication have given equalities?] in TcSimplify
-isFlatSkolEv ev = case ctLocOrigin (ctev_loc ev) of
-                    FlatSkolOrigin -> True
-                    _              -> False
-
 --------------
 insertInertItemTcS :: Ct -> TcS ()
 -- Add a new item in the inerts of the monad
@@ -580,7 +500,7 @@ insertInertItemTcS item
   = do { traceTcS "insertInertItemTcS {" $
          text "Trying to insert new inert item:" <+> ppr item
 
-       ; updInertTcS (\ics -> ics { inert_cans = addInertCan (inert_cans ics) item })
+       ; updInertCans (\ics -> addInertCan ics item)
 
        ; traceTcS "insertInertItemTcS }" $ empty }
 
@@ -594,102 +514,85 @@ addSolvedDict item cls tys
        ; updInertTcS $ \ ics ->
              ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }
 
-addSolvedFunEq :: TyCon -> [TcType] -> CtEvidence -> TcType -> TcS ()
-addSolvedFunEq fam_tc tys ev rhs_ty
-  = updInertTcS $ \ inert ->
-    inert { inert_solved_funeqs = insertFunEq (inert_solved_funeqs inert)
-                                              fam_tc tys (ev, rhs_ty) }
-
 updInertTcS :: (InertSet -> InertSet) -> TcS ()
 -- Modify the inert set with the supplied function
-updInertTcS upd
+updInertTcS upd_fn
   = do { is_var <- getTcSInertsRef
        ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var
-                     ; TcM.writeTcRef is_var (upd curr_inert) }) }
+                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }
 
-prepareInertsForImplications :: InertSet -> InertSet
+getInertCans :: TcS InertCans
+getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }
+
+setInertCans :: InertCans -> TcS ()
+setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }
+
+updInertCans :: (InertCans -> InertCans) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertCans upd_fn
+  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }
+
+updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertDicts upd_fn
+  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts 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
+  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }
+
+
+prepareInertsForImplications :: InertSet -> (InertSet)
 -- See Note [Preparing inert set for implications]
-prepareInertsForImplications is
-  = is { inert_cans    = getGivens (inert_cans is)
-       , inert_fsks    = []
-       , inert_flat_cache = emptyFunEqs }
+prepareInertsForImplications is@(IS { inert_cans = cans })
+  = is { inert_cans       = getGivens cans
+       , inert_flat_cache = emptyFunEqs }  -- See Note [Do not inherit the flat cache]
   where
     getGivens (IC { inert_eqs    = eqs
                   , inert_irreds = irreds
                   , inert_funeqs = funeqs
                   , inert_dicts  = dicts })
-      = IC { inert_eqs     = filterVarEnv is_given_eq eqs
-           , inert_funeqs  = foldFunEqs given_from_wanted funeqs emptyFunEqs
+      = IC { inert_eqs     = filterVarEnv  is_given_ecl eqs
+           , inert_funeqs  = filterFunEqs  isGivenCt funeqs
            , inert_irreds  = Bag.filterBag isGivenCt irreds
-           , inert_dicts   = filterDicts isGivenCt dicts
-           , inert_insols  = emptyCts
-           , inert_no_eqs  = True  -- See Note [inert_fsks and inert_no_eqs]
-           }
-
-    is_given_eq :: [Ct] -> Bool
-    is_given_eq (ct:rest) | isGivenCt ct = ASSERT( null rest ) True
-    is_given_eq _                        = False
-
-    given_from_wanted :: EqualCtList -> FunEqMap EqualCtList -> FunEqMap EqualCtList
-    given_from_wanted (funeq:_) fhm  -- This is where the magic processing happens
-                                     -- for type-function equalities
-                                     -- Pick just the first
-                                     -- See Note [Preparing inert set for implications]
-
-      | isWanted ev  = insert_one (funeq { cc_ev = given_ev }) fhm
-      | isGiven ev   = insert_one funeq fhm
-      where
-        ev = ctEvidence funeq
-        given_ev = CtGiven { ctev_evtm = EvId (ctev_evar ev)
-                           , ctev_pred = ctev_pred ev
-                           , ctev_loc  = ctev_loc ev }
-
-    given_from_wanted _ fhm = fhm -- Drop derived constraints
+           , inert_dicts   = filterDicts   isGivenCt dicts
+           , inert_insols  = emptyCts }
 
-    insert_one :: Ct -> FunEqMap EqualCtList -> FunEqMap EqualCtList
-    insert_one item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys }) fhm
-       = addFunEq fhm tc tys item
-    insert_one item _ = pprPanic "insert_one" (ppr item)
+    is_given_ecl :: EqualCtList -> Bool
+    is_given_ecl (ct:rest) | isGivenCt ct = ASSERT( null rest ) True
+    is_given_ecl _                        = False
 \end{code}
 
+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 perhpas solve it.  Moreover, the fsk from outside is 
+flattened out after solving the outer level, but and we don't 
+do that flattening recursively.
+
 Note [Preparing inert set for implications]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Before solving the nested implications, we trim the inert set,
 retaining only Givens.  These givens can be used when solving
 the inner implications.
 
-With one wrinkle!  We take all *wanted* *funeqs*, and turn them into givens.
-Consider (Trac #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.  But
-Since solveCTyFunEqs happens at the very end of solving, the only way
-to solve the two implications is temporarily consider (F c a b ~ gamma)
-as Given and push it inside the implications. Now, when we come
-out again at the end, having solved the implications solveCTyFunEqs
-will solve this equality.
-
-Turning type-function equalities into Givens is easy becase they
-*stay inert*.  No need to re-process them.
-
-We don't try to turn any *other* Wanteds into Givens:
-
-  * For example, we should not push given dictionaries in because
-    of example LongWayOverlapping.hs, where we might get strange
-    overlap errors between far-away constraints in the program.
-
-There might be cases where interactions between wanteds can help
-to solve a constraint. For example
+There might be cases where interactions between wanteds at different levels
+could help to solve a constraint. For example
 
         class C a b | a -> b
         (C Int alpha), (forall d. C d blah => C Int a)
 
-If we push the (C Int alpha) inwards, as a given, it can produce a
+If we pushed the (C Int alpha) inwards, as a given, it can produce a
 fundep (alpha~a) and this can float out again and be used to fix
 alpha.  (In general we can't float class constraints out just in case
 (C d blah) might help to solve (C Int a).)  But we ignore this possiblity.
@@ -698,36 +601,137 @@ For Derived constraints we don't have evidence, so we do not turn
 them into Givens.  There can *be* deriving CFunEqCans; see Trac #8129.
 
 \begin{code}
-getInertEqs :: TcS (TyVarEnv [Ct])
+getInertEqs :: TcS (TyVarEnv EqualCtList)
 getInertEqs = do { inert <- getTcSInerts
                  ; return (inert_eqs (inert_cans inert)) }
 
-getInertUnsolved :: TcS (Cts, Cts)
--- Return (unsolved-wanteds, insolubles)
--- Both consist of a mixture of Wanted and Derived
-getInertUnsolved
- = do { is <- getTcSInerts
-
-      ; let icans = inert_cans is
-            unsolved_irreds = Bag.filterBag is_unsolved  (inert_irreds icans)
-            unsolved_dicts  = foldDicts  add_if_unsolved  (inert_dicts icans)  emptyCts
-            unsolved_funeqs = foldFunEqs add_if_unsolveds (inert_funeqs icans) emptyCts
-            unsolved_eqs    = foldVarEnv add_if_unsolveds emptyCts (inert_eqs icans)
-
-            unsolved_flats = unsolved_eqs `unionBags` unsolved_irreds `unionBags`
-                             unsolved_dicts `unionBags` unsolved_funeqs
-
-      ; return (unsolved_flats, inert_insols icans) }
+getUnsolvedInerts :: TcS ( Cts     -- Tyvar eqs: a ~ ty
+                         , Cts     -- Fun eqs:   F a ~ ty
+                         , Cts     -- Insoluble
+                         , Cts )   -- All others
+getUnsolvedInerts
+ = do { IC { inert_eqs = tv_eqs, inert_funeqs = fun_eqs
+           , inert_irreds = irreds, inert_dicts = idicts
+           , inert_insols = insols } <- getInertCans
+
+      ; let unsolved_tv_eqs  = foldVarEnv (\cts rest -> foldr add_if_unsolved rest cts)
+                                          emptyCts tv_eqs
+            unsolved_fun_eqs = foldFunEqs add_if_unsolved fun_eqs emptyCts
+            unsolved_irreds  = Bag.filterBag is_unsolved irreds
+            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts
+            others = unsolved_irreds `unionBags` unsolved_dicts
+
+      ; return ( unsolved_tv_eqs, unsolved_fun_eqs, insols, others) }
+              -- Keep even the given insolubles
+              -- so that we can report dead GADT pattern match branches
   where
     add_if_unsolved :: Ct -> Cts -> Cts
-    add_if_unsolved ct cts | is_unsolved ct = cts `extendCts` ct
+    add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts
                            | otherwise      = cts
 
-    add_if_unsolveds :: [Ct] -> Cts -> Cts
-    add_if_unsolveds eqs cts = foldr add_if_unsolved cts eqs
-
     is_unsolved ct = not (isGivenCt ct)   -- Wanted or Derived
 
+getNoGivenEqs :: Untouchables     -- Untouchables of this implication
+               -> [TcTyVar]       -- Skolems of this implication
+               -> TcS Bool        -- True <=> definitely no residual given equalities
+-- See Note [When does an implication have given equalities?]
+getNoGivenEqs untch skol_tvs
+  = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = iirreds, inert_funeqs = funeqs })
+             <- getInertCans
+       ; let local_fsks = foldFunEqs add_fsk funeqs emptyVarSet
+
+             has_given_eqs = foldrBag ((||) . ev_given_here . ctEvidence)  False iirreds
+                          || foldVarEnv ((||) . eqs_given_here local_fsks) False ieqs
+
+       ; traceTcS "getNoGivenEqs" (vcat [ppr has_given_eqs, ppr inerts])
+       ; return (not has_given_eqs) }
+  where
+    eqs_given_here :: VarSet -> EqualCtList -> Bool
+    eqs_given_here local_fsks [CTyEqCan { cc_tyvar = tv, cc_ev = ev }]
+                              -- Givens are always a sigleton
+      = not (skolem_bound_here local_fsks tv) && ev_given_here ev
+    eqs_given_here _ _ = False
+
+    ev_given_here :: CtEvidence -> Bool
+    -- True for a Given bound by the curent implication,
+    -- i.e. the current level
+    ev_given_here ev
+      =  isGiven ev
+      && untch == tcl_untch (ctl_env (ctEvLoc ev))
+
+    add_fsk :: Ct -> VarSet -> VarSet
+    add_fsk ct fsks | CFunEqCan { cc_fsk = tv, cc_ev = ev } <- ct
+                    , isGiven ev = extendVarSet fsks tv
+                    | otherwise  = fsks
+
+    skol_tv_set = mkVarSet skol_tvs
+    skolem_bound_here local_fsks tv -- See Note [Let-bound skolems]
+      = case tcTyVarDetails tv of
+          SkolemTv {} -> tv `elemVarSet` skol_tv_set
+          FlatSkol {} -> not (tv `elemVarSet` local_fsks)
+          _           -> False
+\end{code}
+
+Note [When does an implication have given equalities?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider an implication
+   beta => alpha ~ Int
+where beta is a unification variable that has already been unified
+to () in an outer scope.  Then we can float the (alpha ~ Int) out
+just fine. So when deciding whether the givens contain an equality,
+we should canonicalise first, rather than just looking at the original
+givens (Trac #8644).
+
+So we simply look at the inert, canonical Givens and see if there are
+any equalities among them, the calculation of has_given_eqs.  There
+are some wrinkles:
+
+ * We must know which ones are bound in *this* implication and which
+   are bound further out.  We can find that out from the Untouchable
+   level of the Given, which is itself recorded in the tcl_untch field
+   of the TcLclEnv stored in the Given (ev_given_here).
+
+   What about interactions between inner and outer givens?
+      - Outer given is rewritten by an inner given, then there must
+        have been an inner given equality, hence the “given-eq” flag
+        will be true anyway.
+
+      - Inner given rewritten by outer, retains its level (ie. The inner one)
+
+ * We must take account of *potential* equalities, like the one above:
+      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.
+
+ * 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'.
+
+ * See Note [Let-bound skolems] for another wrinkle
+
+Note [Let-bound skolems]
+~~~~~~~~~~~~~~~~~~~~~~~~
+If   * the inert set contains a canonical Given CTyEqCan (a ~ ty)
+and  * 'a' is a skolem bound in this very implication, b
+
+then:
+a) The Given is pretty much a let-binding, like
+      f :: (a ~ b->c) => a -> a
+   Here the equality constraint is like saying
+      let a = b->c in ...
+   It is not adding any new, local equality  information,
+   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'
+
+For an example, see Trac #9211.
+
+\begin{code}
 checkAllSolved :: TcS Bool
 -- True if there are no unsolved wanteds
 -- Ignore Derived for this purpose, unless in insolubles
@@ -736,28 +740,29 @@ checkAllSolved
 
       ; let icans = inert_cans is
             unsolved_irreds = Bag.anyBag isWantedCt (inert_irreds icans)
-            unsolved_dicts  = foldDicts ((||)  . isWantedCt)     (inert_dicts icans)  False
-            unsolved_funeqs = foldFunEqs ((||) . any isWantedCt) (inert_funeqs icans) False
+            unsolved_dicts  = foldDicts ((||)  . isWantedCt) (inert_dicts icans)  False
+            unsolved_funeqs = foldFunEqs ((||) . isWantedCt) (inert_funeqs icans) False
             unsolved_eqs    = foldVarEnv ((||) . any isWantedCt) False (inert_eqs icans)
 
       ; return (not (unsolved_eqs || unsolved_irreds
                      || unsolved_dicts || unsolved_funeqs
                      || not (isEmptyBag (inert_insols icans)))) }
 
-lookupFlatEqn :: TyCon -> [Type] -> TcS (Maybe (CtEvidence, TcType))
-lookupFlatEqn fam_tc tys
-  = do { IS { inert_solved_funeqs = solved_funeqs
-            , inert_flat_cache = flat_cache
+lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcTyVar))
+lookupFlatCache fam_tc tys
+  = do { IS { inert_flat_cache = flat_cache
             , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts
-       ; return (firstJusts [findFunEq solved_funeqs fam_tc tys,
-                             lookup_inerts inert_funeqs,
-                             findFunEq flat_cache fam_tc tys]) }
+       ; return (firstJusts [lookup_inerts inert_funeqs,
+                             lookup_flats flat_cache]) }
   where
     lookup_inerts inert_funeqs
-      | (ct:_) <- findFunEqs inert_funeqs fam_tc tys
-      = Just (ctEvidence ct, cc_rhs ct)
-      | otherwise
-      = Nothing
+      | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk })
+           <- findFunEqs inert_funeqs fam_tc tys
+      = Just (ctEvCoercion ctev, fsk)
+      | otherwise = Nothing
+
+    lookup_flats flat_cache = findFunEq flat_cache fam_tc tys
+
 
 lookupInInerts :: TcPredType -> TcS (Maybe CtEvidence)
 -- Is this exact predicate type cached in the solved or canonicals of the InertSet?
@@ -768,30 +773,12 @@ lookupInInerts pty
        ; return $ case (classifyPredType pty) of
            ClassPred cls tys
               | Just ctev <- findDict solved_dicts cls tys
-                    -- I'm not sure why we check for solved dicts,
-                    -- but not for solved funeqs
               -> Just ctev
               | Just ct <- findDict (inert_dicts inert_cans) cls tys
               -> Just (ctEvidence ct)
 
-           EqPred ty1 _ty2
-             | Just tv <- getTyVar_maybe ty1      -- Tyvar equation
-             -> foldr exact_match Nothing (findTyEqs (inert_eqs inert_cans) tv)
-
-             | Just (tc, tys) <- splitTyConApp_maybe ty1  -- Family equation
-             -> foldr exact_match Nothing (findFunEqs (inert_funeqs inert_cans) tc tys)
-
-           IrredPred {} -> foldrBag exact_match Nothing (inert_irreds inert_cans)
-
-           _other -> Nothing -- NB: No caching for IPs or holes
+           _other -> Nothing -- NB: No caching for equalities, IPs, holes, or errors
       }
-  where
-    exact_match :: Ct -> Maybe CtEvidence -> Maybe CtEvidence
-    exact_match ct deflt | let ctev = ctEvidence ct
-                         , ctEvPred ctev `tcEqType` pty
-                         = Just ctev
-                         | otherwise
-                         = deflt
 
 lookupSolvedDict :: InertSet -> Class -> [Type] -> Maybe CtEvidence
 -- Returns just if exactly this predicate type exists in the solved.
@@ -840,6 +827,23 @@ insertTcApp m cls tys ct = alterUFM alter_tm m cls
   where
     alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))
 
+-- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b
+-- mapTcApp f = mapUFM (mapTM f)
+
+filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct
+filterTcAppMap f m
+  = mapUFM do_tm 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)
+
 tcAppMapToBag :: TcAppMap a -> Bag a
 tcAppMapToBag m = foldTcAppMap consBag m emptyBag
 
@@ -877,13 +881,7 @@ addDictsByClass m cls items
     add ct _ = pprPanic "addDictsByClass" (ppr ct)
 
 filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct
-filterDicts f m = mapUFM do_tm m
-  where
-    do_tm tm = foldTM insert_mb tm emptyTM
-    insert_mb ct@(CDictCan { cc_tyargs = tys }) tm
-       | f ct      = insertTM tys ct tm
-       | otherwise = tm
-    insert_mb ct _ = pprPanic "filterDicts" (ppr ct)
+filterDicts f m = filterTcAppMap f m
 
 partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)
 partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts)
@@ -915,51 +913,44 @@ sizeFunEqMap m = foldFunEqs (\ _ x -> x+1) m 0
 findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a
 findFunEq m tc tys = findTcApp m (getUnique tc) tys
 
-findFunEqs :: FunEqMap [a] -> TyCon -> [Type] -> [a]
-findFunEqs m tc tys = findTcApp m (getUnique tc) tys `orElse` []
+findFunEqs :: FunEqMap a -> TyCon -> [Type] -> Maybe a
+findFunEqs m tc tys = findTcApp m (getUnique tc) tys
 
-funEqsToList :: FunEqMap [a] -> [a]
-funEqsToList m = foldTcAppMap (++) m []
+funEqsToList :: FunEqMap a -> [a]
+funEqsToList m = foldTcAppMap (:) m []
 
-findFunEqsByTyCon :: FunEqMap [a] -> TyCon -> [a]
+findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
 -- Get inert function equation constraints that have the given tycon
 -- in their head.  Not that the constraints remain in the inert set.
 -- We use this to check for derived interactions with built-in type-function
 -- constructors.
 findFunEqsByTyCon m tc
-  | Just tm <- lookupUFM m tc = foldTM (++) tm []
+  | Just tm <- lookupUFM 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
+
 insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
 insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val
 
-addFunEq :: FunEqMap EqualCtList -> TyCon -> [Type] -> Ct -> FunEqMap EqualCtList
-addFunEq m tc tys item
-  = alterUFM alter_tm m (getUnique tc)
-  where
-    alter_tm mb_tm = Just (alterTM tys alter_cts (mb_tm `orElse` emptyTM))
-    alter_cts Nothing       = Just [item]
-    alter_cts (Just funeqs) = Just (item : funeqs)
-
-replaceFunEqs :: FunEqMap EqualCtList -> TyCon -> [Type] -> Ct -> FunEqMap EqualCtList
-replaceFunEqs m tc tys ct = insertTcApp m (getUnique tc) tys [ct]
+insertFunEqCt :: FunEqMap Ct -> Ct -> FunEqMap Ct
+insertFunEqCt m ct@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })
+  = insertFunEq m tc tys ct
+insertFunEqCt _ ct = pprPanic "insertFunEqCt" (ppr ct)
 
-partitionFunEqs :: (Ct -> Bool) -> FunEqMap EqualCtList -> (Bag Ct, FunEqMap EqualCtList)
+partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> (Bag Ct, FunEqMap Ct)
 partitionFunEqs f m = foldTcAppMap k m (emptyBag, emptyFunEqs)
   where
-    k cts (yeses, noes)
-      = ( case eqs_out of
-            [] -> yeses
-            _  -> yeses `unionBags` listToBag eqs_out
-        , case eqs_in of
-            CFunEqCan { cc_fun = tc, cc_tyargs = tys } : _
-                -> insertTcApp noes (getUnique tc) tys eqs_in
-            _  -> noes )
-      where
-        (eqs_out, eqs_in) = partition f cts
+    k ct (yeses, noes)
+      | f ct      = (yeses `snocBag` ct, noes)
+      | otherwise = (yeses, insertFunEqCt noes ct)
 \end{code}
 
 
@@ -987,21 +978,14 @@ data TcSEnv
   = TcSEnv {
       tcs_ev_binds    :: EvBindsVar,
 
-      tcs_ty_binds :: IORef (Bool, TyVarEnv (TcTyVar, TcType)),
-          -- Global type bindings for unification variables
-          -- See Note [Spontaneously solved in TyBinds] in TcInteract
-          -- The "dirty-flag" Bool is set True when we add a binding
+      tcs_unified :: IORef Bool,
+          -- The "dirty-flag" Bool is set True when 
+          -- we unify a unification variable
 
       tcs_count    :: IORef Int, -- Global step count
 
       tcs_inerts   :: IORef InertSet, -- Current inert set
-      tcs_worklist :: IORef WorkList, -- Current worklist
-
-      -- Residual implication constraints that are generated
-      -- while solving or canonicalising the current worklist.
-      -- Specifically, when canonicalising (forall a. t1 ~ forall a. t2)
-      -- from which we get the implication (forall a. t1 ~ t2)
-      tcs_implics  :: IORef (Bag Implication)
+      tcs_worklist :: IORef WorkList  -- Current worklist
     }
 \end{code}
 
@@ -1061,17 +1045,29 @@ bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env
                                     ; n <- TcM.readTcRef ref
                                     ; TcM.writeTcRef ref (n+1) }
 
-traceFireTcS :: Ct -> SDoc -> TcS ()
+csTraceTcS :: SDoc -> TcS ()
+csTraceTcS doc
+  = wrapTcS $ csTraceTcM 1 (return doc)
+
+traceFireTcS :: CtEvidence -> SDoc -> TcS ()
 -- Dump a rule-firing trace
-traceFireTcS ct doc
-  = TcS $ \env ->
-    do { dflags <- getDynFlags
-       ; when (dopt Opt_D_dump_cs_trace dflags && traceLevel dflags >= 1) $
+traceFireTcS ev doc
+  = TcS $ \env -> csTraceTcM 1 $
     do { n <- TcM.readTcRef (tcs_count env)
-       ; let msg = int n <> brackets (ppr (ctLocDepth (ctev_loc ev)))
-                   <+> ppr ev <> colon <+> doc
-       ; TcM.debugDumpTcRn msg } }
-  where ev = cc_ev ct
+       ; untch <- TcM.getUntouchables
+       ; return (hang (int n <> brackets (ptext (sLit "U:") <> ppr untch 
+                                          <> ppr (ctLocDepth (ctEvLoc ev))) 
+                       <+> doc <> colon)
+                     4 (ppr ev)) } 
+
+csTraceTcM :: Int -> TcM SDoc -> TcM ()
+-- Constraint-solver tracing, -ddump-cs-trace
+csTraceTcM trace_level mk_doc
+  = do { dflags <- getDynFlags
+       ; when ((dopt Opt_D_dump_cs_trace dflags || dopt Opt_D_dump_tc_trace dflags)
+               && traceLevel dflags >= trace_level) $
+         do { msg <- mk_doc
+            ; TcM.debugDumpTcRn msg } }
 
 runTcS :: TcS a                -- What to run
        -> TcM (a, Bag EvBind)
@@ -1085,28 +1081,23 @@ runTcSWithEvBinds :: EvBindsVar
                   -> TcS a
                   -> TcM a
 runTcSWithEvBinds ev_binds_var tcs
-  = do { ty_binds_var <- TcM.newTcRef (False, emptyVarEnv)
+  = do { unified_var <- TcM.newTcRef False
        ; step_count <- TcM.newTcRef 0
        ; inert_var <- TcM.newTcRef is
+       ; wl_var <- TcM.newTcRef emptyWorkList
 
        ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
-                          , tcs_ty_binds = ty_binds_var
+                          , tcs_unified  = unified_var
                           , tcs_count    = step_count
                           , tcs_inerts   = inert_var
-                          , tcs_worklist    = panic "runTcS: worklist"
-                          , tcs_implics     = panic "runTcS: implics" }
-                               -- NB: Both these are initialised by withWorkList
+                          , tcs_worklist = wl_var }
 
              -- Run the computation
        ; res <- unTcS tcs env
-             -- Perform the type unifications required
-       ; (_, ty_binds) <- TcM.readTcRef ty_binds_var
-       ; mapM_ do_unification (varEnvElts ty_binds)
 
-       ; TcM.whenDOptM Opt_D_dump_cs_trace $
-         do { count <- TcM.readTcRef step_count
-            ; when (count > 0) $
-              TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count ) }
+       ; count <- TcM.readTcRef step_count
+       ; when (count > 0) $ 
+         csTraceTcM 0 $ return (ptext (sLit "Constraint solver steps =") <+> int count)
 
 #ifdef DEBUG
        ; ev_binds <- TcM.getTcEvBinds ev_binds_var
@@ -1115,7 +1106,6 @@ runTcSWithEvBinds ev_binds_var tcs
 
        ; return res }
   where
-    do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
     is = emptyInert
 
 #ifdef DEBUG
@@ -1138,19 +1128,21 @@ checkForCyclicBinds ev_binds
     edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds]
 #endif
 
-nestImplicTcS :: EvBindsVar -> Untouchables -> InertSet -> TcS a -> TcS a
-nestImplicTcS ref inner_untch inerts (TcS thing_inside)
-  = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds
+nestImplicTcS :: EvBindsVar -> Untouchables -> TcS a -> TcS a
+nestImplicTcS ref inner_untch (TcS thing_inside)
+  = TcS $ \ TcSEnv { tcs_unified = unified_var
+                   , tcs_inerts = old_inert_var
                    , tcs_count = count } ->
-    do { new_inert_var <- TcM.newTcRef inerts
+    do { inerts <- TcM.readTcRef old_inert_var
+       ; let nest_inert = inerts { inert_flat_cache = emptyFunEqs }
+                                   -- See Note [Do not inherit the flat cache]
+       ; new_inert_var <- TcM.newTcRef nest_inert
+       ; new_wl_var    <- TcM.newTcRef emptyWorkList
        ; let nest_env = TcSEnv { tcs_ev_binds    = ref
-                               , tcs_ty_binds    = ty_binds
+                               , tcs_unified     = unified_var
                                , tcs_count       = count
                                , tcs_inerts      = new_inert_var
-                               , tcs_worklist    = panic "nestImplicTcS: worklist"
-                               , tcs_implics     = panic "nestImplicTcS: implics"
-                               -- NB: Both these are initialised by withWorkList
-                               }
+                               , tcs_worklist    = new_wl_var }
        ; res <- TcM.setUntouchables inner_untch $
                 thing_inside nest_env
 
@@ -1169,34 +1161,31 @@ recoverTcS (TcS recovery_code) (TcS thing_inside)
 
 nestTcS ::  TcS a -> TcS a
 -- Use the current untouchables, augmenting the current
--- evidence bindings, ty_binds, and solved caches
+-- evidence bindings, and solved caches
 -- But have no effect on the InertCans or insolubles
 nestTcS (TcS thing_inside)
   = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->
     do { inerts <- TcM.readTcRef inerts_var
        ; new_inert_var <- TcM.newTcRef inerts
+       ; new_wl_var    <- TcM.newTcRef emptyWorkList
        ; let nest_env = env { tcs_inerts   = new_inert_var
-                            , tcs_worklist = panic "nestTcS: worklist"
-                            , tcs_implics  = panic "nestTcS: implics" }
+                            , tcs_worklist = new_wl_var }
        ; thing_inside nest_env }
 
 tryTcS :: TcS a -> TcS a
 -- Like runTcS, but from within the TcS monad
 -- Completely fresh inerts and worklist, be careful!
 -- Moreover, we will simply throw away all the evidence generated.
--- We have a completely empty tcs_ty_binds too, so make sure the
--- input stuff is fully rewritten wrt any outer inerts
 tryTcS (TcS thing_inside)
   = TcS $ \env ->
     do { is_var <- TcM.newTcRef emptyInert
-       ; ty_binds_var <- TcM.newTcRef (False, emptyVarEnv)
+       ; unified_var <- TcM.newTcRef False
        ; ev_binds_var <- TcM.newTcEvBinds
-
+       ; wl_var <- TcM.newTcRef emptyWorkList
        ; let nest_env = env { tcs_ev_binds = ev_binds_var
-                            , tcs_ty_binds = ty_binds_var
+                            , tcs_unified  = unified_var
                             , tcs_inerts   = is_var
-                            , tcs_worklist = panic "tryTcS: worklist"
-                            , tcs_implics  = panic "tryTcS: implics" }
+                            , tcs_worklist = wl_var }
        ; thing_inside nest_env }
 
 -- Getters and setters of TcEnv fields
@@ -1215,6 +1204,12 @@ getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef)
 setTcSInerts :: InertSet -> TcS ()
 setTcSInerts ics = do { r <- getTcSInertsRef; wrapTcS (TcM.writeTcRef r ics) }
 
+getWorkListImplics :: TcS (Bag Implication)
+getWorkListImplics
+  = do { wl_var <- getTcSWorkListRef
+       ; wl_curr <- wrapTcS (TcM.readTcRef wl_var)
+       ; return (wl_implics wl_curr) }
+
 updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
 updWorkListTcS f
   = do { wl_var <- getTcSWorkListRef
@@ -1228,32 +1223,18 @@ updWorkListTcS_return :: (WorkList -> (a,WorkList)) -> TcS a
 updWorkListTcS_return f
   = do { wl_var <- getTcSWorkListRef
        ; wl_curr <- wrapTcS (TcM.readTcRef wl_var)
+       ; traceTcS "updWorkList" (ppr wl_curr)
        ; let (res,new_work) = f wl_curr
        ; wrapTcS (TcM.writeTcRef wl_var new_work)
        ; return res }
 
-withWorkList :: Cts -> TcS () -> TcS (Bag Implication)
--- Use 'thing_inside' to solve 'work_items', extending the
--- ambient InertSet, and returning any residual implications
--- (arising from polytype equalities)
--- We do this with fresh work list and residual-implications variables
-withWorkList work_items (TcS thing_inside)
-  = TcS $ \ tcs_env ->
-    do { let init_work_list = foldrBag extendWorkListCt emptyWorkList work_items
-       ; new_wl_var <- TcM.newTcRef init_work_list
-       ; new_implics_var <- TcM.newTcRef emptyBag
-       ; thing_inside (tcs_env { tcs_worklist = new_wl_var
-                               , tcs_implics = new_implics_var })
-       ; final_wl <- TcM.readTcRef new_wl_var
-       ; implics  <- TcM.readTcRef new_implics_var
-       ; ASSERT( isEmptyWorkList final_wl )
-         return implics }
-
-updTcSImplics :: (Bag Implication -> Bag Implication) -> TcS ()
-updTcSImplics f
- = do { impl_ref <- getTcSImplicsRef
-      ; wrapTcS $ do { implics <- TcM.readTcRef impl_ref
-                     ; TcM.writeTcRef impl_ref (f implics) } }
+emitWorkNC :: [CtEvidence] -> TcS ()
+emitWorkNC evs
+  | null evs
+  = return ()
+  | otherwise
+  = do { traceTcS "Emitting fresh work" (vcat (map ppr evs))
+       ; updWorkListTcS (extendWorkListCts (map mkNonCanonical evs)) }
 
 emitInsoluble :: Ct -> TcS ()
 -- Emits a non-canonical constraint that will stand for a frozen error in the inerts.
@@ -1264,58 +1245,19 @@ emitInsoluble ct
     this_pred = ctPred ct
     add_insol is@(IS { inert_cans = ics@(IC { inert_insols = old_insols }) })
       | already_there = is
-      | otherwise     = is { inert_cans = ics { inert_insols = extendCts old_insols ct } }
+      | otherwise     = is { inert_cans = ics { inert_insols = old_insols `snocCts` ct } }
       where
         already_there = not (isWantedCt ct) && anyBag (tcEqType this_pred . ctPred) old_insols
              -- See Note [Do not add duplicate derived insolubles]
 
-getTcSImplicsRef :: TcS (IORef (Bag Implication))
-getTcSImplicsRef = TcS (return . tcs_implics)
-
 getTcEvBinds :: TcS EvBindsVar
 getTcEvBinds = TcS (return . tcs_ev_binds)
 
 getUntouchables :: TcS Untouchables
 getUntouchables = wrapTcS TcM.getUntouchables
-
-getGivenInfo :: TcS a -> TcS (Bool, [TcTyVar], a)
--- See Note [inert_fsks and inert_no_eqs]
-getGivenInfo thing_inside
-  = do { updInertTcS reset_vars  -- Set inert_fsks and inert_no_eqs to initial values
-       ; res <- thing_inside     -- Run thing_inside
-       ; is  <- getTcSInerts     -- Get new values of inert_fsks and inert_no_eqs
-       ; return (inert_no_eqs (inert_cans is), inert_fsks is, res) }
-  where
-    reset_vars :: InertSet -> InertSet
-    reset_vars is = is { inert_cans = (inert_cans is) { inert_no_eqs = True }
-                       , inert_fsks = [] }
 \end{code}
 
-Note [inert_fsks and inert_no_eqs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The function getGivenInfo runs thing_inside to see what new flatten-skolems
-and equalities are generated by thing_inside.  To that end,
- * it initialises inert_fsks, inert_no_eqs
- * runs thing_inside
- * reads out inert_fsks, inert_no_eqs
-This is the only place where it matters what inert_fsks and inert_no_eqs
-are initialised to.  In other places (eg emptyIntert), we need to set them
-to something (because they are strict) but they will never be looked at.
-
-See Note [When does an implication have given equalities?] in TcSimplify
-for more details about inert_no_eqs.
-
-See Note [Given flatten-skolems] for more details about inert_fsks.
-
 \begin{code}
-getTcSTyBinds :: TcS (IORef (Bool, TyVarEnv (TcTyVar, TcType)))
-getTcSTyBinds = TcS (return . tcs_ty_binds)
-
-getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
-getTcSTyBindsMap = do { ref <- getTcSTyBinds
-                      ; wrapTcS $ do { (_, binds) <- TcM.readTcRef ref
-                                     ; return binds } }
-
 getTcEvBindsMap :: TcS EvBindMap
 getTcEvBindsMap
   = do { EvBindsVar ev_ref _ <- getTcEvBinds
@@ -1325,33 +1267,26 @@ setWantedTyBind :: TcTyVar -> TcType -> TcS ()
 -- Add a type binding
 -- We never do this twice!
 setWantedTyBind tv ty
+  | ASSERT2( isMetaTyVar tv, ppr tv )
+    isFmvTyVar tv
   = ASSERT2( isMetaTyVar tv, ppr tv )
-    do { ref <- getTcSTyBinds
-       ; wrapTcS $
-         do { (_dirty, ty_binds) <- TcM.readTcRef ref
-            ; when debugIsOn $
-                  TcM.checkErr (not (tv `elemVarEnv` ty_binds)) $
-                  vcat [ text "TERRIBLE ERROR: double set of meta type variable"
-                       , ppr tv <+> text ":=" <+> ppr ty
-                       , text "Old value =" <+> ppr (lookupVarEnv_NF ty_binds tv)]
-            ; TcM.traceTc "setWantedTyBind" (ppr tv <+> text ":=" <+> ppr ty)
-            ; TcM.writeTcRef ref (True, extendVarEnv ty_binds tv (tv,ty)) } }
+    wrapTcS (TcM.writeMetaTyVar tv ty)
+           -- Write directly into the mutable tyvar
+           -- Flatten meta-vars are born and die locally
+
+  | otherwise
+  = TcS $ \ env ->
+    do { TcM.traceTc "setWantedTyBind" (ppr tv <+> text ":=" <+> ppr ty)
+       ; TcM.writeMetaTyVar tv ty
+       ; TcM.writeTcRef (tcs_unified env) True }
 
 reportUnifications :: TcS a -> TcS (Bool, a)
-reportUnifications thing_inside
-  = do { ty_binds_var <- getTcSTyBinds
-       ; outer_dirty <- wrapTcS $
-            do { (outer_dirty, binds1) <- TcM.readTcRef ty_binds_var
-               ; TcM.writeTcRef ty_binds_var (False, binds1)
-               ; return outer_dirty }
-      ; res <- thing_inside
-      ; wrapTcS $
-        do { (inner_dirty, binds2) <- TcM.readTcRef ty_binds_var
-           ; if inner_dirty then
-                 return (True, res)
-             else
-                do { TcM.writeTcRef ty_binds_var (outer_dirty, binds2)
-                   ; return (False, res) } } }
+reportUnifications (TcS thing_inside)
+  = TcS $ \ env ->
+    do { inner_unified <- TcM.newTcRef False
+       ; res <- thing_inside (env { tcs_unified = inner_unified })
+       ; dirty <- TcM.readTcRef inner_unified
+       ; return (dirty, res) }
 \end{code}
 
 \begin{code}
@@ -1410,8 +1345,20 @@ isFilledMetaTyVar_maybe tv
                   Flexi       -> return Nothing }
      _ -> return Nothing
 
+isFilledMetaTyVar :: TcTyVar -> TcS Bool
+isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)
+
 zonkTyVarsAndFV :: TcTyVarSet -> TcS TcTyVarSet
 zonkTyVarsAndFV tvs = wrapTcS (TcM.zonkTyVarsAndFV tvs)
+
+zonkTcType :: TcType -> TcS TcType
+zonkTcType ty = wrapTcS (TcM.zonkTcType ty)
+
+zonkTcTyVar :: TcTyVar -> TcS TcType
+zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)
+
+zonkFlats :: Cts -> TcS Cts
+zonkFlats cts = wrapTcS (TcM.zonkFlats cts)
 \end{code}
 
 Note [Do not add duplicate derived insolubles]
@@ -1468,41 +1415,39 @@ which will result in two Deriveds to end up in the insoluble set:
 \begin{code}
 -- Flatten skolems
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-newFlattenSkolem :: CtEvidence
-                 -> TcType                      -- F xis
-                 -> TcS (CtEvidence, TcType)    -- co :: F xis ~ ty
--- We have already looked up in the cache; no need to so so again
-newFlattenSkolem ev fam_ty
-  | isGiven ev
-  = do { tv <- wrapTcS $
-               do { uniq <- TcM.newUnique
-                  ; let name = TcM.mkTcTyVarName uniq (fsLit "f")
-                  ; return $ mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty) }
-       ; traceTcS "New Flatten Skolem Born" $
-         ppr tv <+> text "[:= " <+> ppr fam_ty <+> text "]"
-
-       ; updInertTcS $ \ is -> is { inert_fsks = tv : inert_fsks is }
-
-       ; let rhs_ty = mkTyVarTy tv
-             ctev = CtGiven { ctev_pred = mkTcEqPred fam_ty rhs_ty
-                            , ctev_evtm = EvCoercion (mkTcNomReflCo fam_ty)
-                            , ctev_loc =  (ctev_loc ev) { ctl_origin = FlatSkolOrigin } }
-       ; return (ctev, rhs_ty) }
-
-  | otherwise  -- Wanted or Derived: make new unification variable
-  = do { rhs_ty <- newFlexiTcSTy (typeKind fam_ty)
-       ; ctev <- newWantedEvVarNC (ctev_loc ev) (mkTcEqPred fam_ty rhs_ty)
-                          -- NC (no-cache) version because we've already
-                          -- looked in the solved goals and inerts (lookupFlatEqn)
-       ; return (ctev, rhs_ty) }
-
-
-extendFlatCache :: TyCon -> [Type] -> CtEvidence -> TcType -> TcS ()
-extendFlatCache tc xi_args ev rhs_xi
+newFlattenSkolem :: CtEvidence -> TcType         -- F xis
+                 -> TcS (CtEvidence, TcTyVar)    -- [W] x:: F xis ~ fsk
+newFlattenSkolem ctxt_ev fam_ty
+  | isGiven ctxt_ev   -- Make a given
+  =  do { fsk <- wrapTcS $
+                 do { uniq <- TcM.newUnique
+                    ; let name = TcM.mkTcTyVarName uniq (fsLit "fsk")
+                    ; return (mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty)) }
+        ; let ev = CtGiven { ctev_pred = mkTcEqPred fam_ty (mkTyVarTy fsk)
+                           , ctev_evtm = EvCoercion (mkTcNomReflCo fam_ty)
+                           , ctev_loc  = loc }
+        ; return (ev, fsk) }
+
+  | otherwise        -- Make a wanted
+  = do { fuv <- wrapTcS $
+                 do { uniq <- TcM.newUnique
+                    ; ref  <- TcM.newMutVar Flexi
+                    ; let details = MetaTv { mtv_info  = FlatMetaTv
+                                           , mtv_ref   = ref
+                                           , mtv_untch = fskUntouchables }
+                          name = TcM.mkTcTyVarName uniq (fsLit "s")
+                    ; return (mkTcTyVar name (typeKind fam_ty) details) }
+       ; ev <- newWantedEvVarNC loc (mkTcEqPred fam_ty (mkTyVarTy fuv))
+       ; return (ev, fuv) }
+  where
+    loc = ctEvLoc ctxt_ev
+
+extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcTyVar) -> TcS ()
+extendFlatCache tc xi_args (co, fsk)
   = do { dflags <- getDynFlags
        ; when (gopt Opt_FlatCache dflags) $
          updInertTcS $ \ is@(IS { inert_flat_cache = fc }) ->
-            is { inert_flat_cache = insertFunEq fc tc xi_args (ev, rhs_xi) } }
+            is { inert_flat_cache = insertFunEq fc tc xi_args (co, fsk) } }
 
 -- Instantiations
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1532,6 +1477,15 @@ newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)
 cloneMetaTyVar :: TcTyVar -> TcS TcTyVar
 cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)
 
+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 } }
+
 instFlexiTcS :: [TKVar] -> TcS (TvSubst, [TcType])
 instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs)
   where
@@ -1562,88 +1516,96 @@ data XEvTerm
             -- and each EvTerm has type of the corresponding EvPred
             }
 
-data MaybeNew = Fresh CtEvidence | Cached EvTerm
-
-isFresh :: MaybeNew -> Bool
-isFresh (Fresh {}) = True
-isFresh _ = False
-
-getEvTerm :: MaybeNew -> EvTerm
-getEvTerm (Fresh ctev) = ctEvTerm ctev
-getEvTerm (Cached tm)  = tm
+data Freshness = Fresh | Cached
 
-getEvTerms :: [MaybeNew] -> [EvTerm]
-getEvTerms = map getEvTerm
-
-freshGoal :: MaybeNew -> Maybe CtEvidence
-freshGoal (Fresh ctev) = Just ctev
-freshGoal _ = Nothing
-
-freshGoals :: [MaybeNew] -> [CtEvidence]
-freshGoals mns = [ ctev | Fresh ctev <- mns ]
+freshGoals :: [(CtEvidence, Freshness)] -> [CtEvidence]
+freshGoals mns = [ ctev | (ctev, Fresh) <- mns ]
 
 setEvBind :: EvVar -> EvTerm -> TcS ()
 setEvBind the_ev tm
-  = do { traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr the_ev
-                                     , text "tm  =" <+> ppr tm ]
-       ; tc_evbinds <- getTcEvBinds
+  = do { tc_evbinds <- getTcEvBinds
        ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm }
 
+newTcEvBinds :: TcS EvBindsVar
+newTcEvBinds = wrapTcS TcM.newTcEvBinds
+
+newEvVar :: TcPredType -> TcS EvVar
+newEvVar pred = wrapTcS (TcM.newEvVar pred)
+
 newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence
 -- Make a new variable of the given PredType,
 -- immediately bind it to the given term
 -- and return its CtEvidence
 newGivenEvVar loc (pred, rhs)
-  = do { new_ev <- wrapTcS $ TcM.newEvVar pred
+  = do { new_ev <- newEvVar pred
        ; setEvBind new_ev rhs
        ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev, ctev_loc = loc }) }
 
 newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence
 -- Don't look up in the solved/inerts; we know it's not there
 newWantedEvVarNC loc pty
-  = do { new_ev <- wrapTcS $ TcM.newEvVar pty
+  = do { new_ev <- newEvVar pty
        ; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc })}
 
 -- | Variant of newWantedEvVar that has a lower bound on the depth of the result
 --   (see Note [Preventing recursive dictionaries])
-newWantedEvVarNonrec :: CtLoc -> TcPredType -> TcS MaybeNew
+newWantedEvVarNonrec :: CtLoc -> TcPredType -> TcS (CtEvidence, Freshness)
 newWantedEvVarNonrec loc pty
   = do { mb_ct <- lookupInInerts pty
        ; case mb_ct of
             Just ctev | not (isDerived ctev) && ctEvCheckDepth (ctLocDepth loc) ctev
                       -> do { traceTcS "newWantedEvVarNonrec/cache hit" $ ppr ctev
-                            ; return (Cached (ctEvTerm ctev)) }
+                            ; return (ctev, Cached) }
             _ -> do { ctev <- newWantedEvVarNC loc pty
                     ; traceTcS "newWantedEvVarNonrec/cache miss" $ ppr ctev
-                    ; return (Fresh ctev) } }
+                    ; return (ctev, Fresh) } }
 
-newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew
+newWantedEvVar :: CtLoc -> TcPredType -> TcS (CtEvidence, Freshness)
 newWantedEvVar loc pty
   = do { mb_ct <- lookupInInerts pty
        ; case mb_ct of
             Just ctev | not (isDerived ctev)
                       -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
-                            ; return (Cached (ctEvTerm ctev)) }
+                            ; return (ctev, Cached) }
             _ -> do { ctev <- newWantedEvVarNC loc pty
                     ; traceTcS "newWantedEvVar/cache miss" $ ppr ctev
-                    ; return (Fresh ctev) } }
+                    ; return (ctev, Fresh) } }
+
+emitNewDerivedEq :: CtLoc -> Pair TcType -> TcS ()
+-- Create new Derived and put it in the work list
+emitNewDerivedEq loc (Pair ty1 ty2)
+  | ty1 `tcEqType` ty2   -- Quite common!
+  = return ()
+  | otherwise
+  = emitNewDerived loc (mkTcEqPred ty1 ty2)
+
+emitNewDerived :: CtLoc -> TcPredType -> TcS ()
+-- Create new Derived and put it in the work list
+emitNewDerived loc pred
+  = do { mb_ct <- lookupInInerts pred
+       ; case mb_ct of
+           Just {} -> return ()
+           Nothing -> do { traceTcS "Emitting [D]" (ppr der_ct)
+                         ; updWorkListTcS (extendWorkListCt der_ct) } }
+  where
+    der_ct = mkNonCanonical (CtDerived { ctev_pred = pred, ctev_loc = loc })
 
 newDerived :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
 -- Returns Nothing    if cached,
 --         Just pred  if not cached
-newDerived loc pty
-  = do { mb_ct <- lookupInInerts pty
+newDerived loc pred
+  = do { mb_ct <- lookupInInerts pred
        ; return (case mb_ct of
                     Just {} -> Nothing
-                    Nothing -> Just (CtDerived { ctev_pred = pty, ctev_loc = loc })) }
+                    Nothing -> Just (CtDerived { ctev_pred = pred, ctev_loc = loc })) }
 
-instDFunConstraints :: CtLoc -> TcThetaType -> TcS [MaybeNew]
+instDFunConstraints :: CtLoc -> TcThetaType -> TcS [(CtEvidence, Freshness)]
 instDFunConstraints loc = mapM (newWantedEvVar loc)
 \end{code}
 
 
-Note [xCFlavor]
-~~~~~~~~~~~~~~~
+Note [xCtEvidence]
+~~~~~~~~~~~~~~~~~~
 A call might look like this:
 
     xCtEvidence ev evidence-transformer
@@ -1717,13 +1679,21 @@ TcCanonical), and will do no harm.
 \begin{code}
 xCtEvidence :: CtEvidence            -- Original evidence
             -> XEvTerm               -- Instructions about how to manipulate evidence
-            -> TcS [CtEvidence]
+            -> TcS ()
+
+xCtEvidence (CtWanted { ctev_evar = evar, ctev_loc = loc })
+            (XEvTerm { ev_preds = ptys, ev_comp = comp_fn })
+  = do { new_evars <- mapM (newWantedEvVar loc) ptys
+       ; setEvBind evar (comp_fn (map (ctEvTerm . fst) new_evars))
+       ; emitWorkNC (freshGoals new_evars) }
+         -- Note the "NC": these are fresh goals, not necessarily canonical
 
 xCtEvidence (CtGiven { ctev_evtm = tm, ctev_loc = loc })
             (XEvTerm { ev_preds = ptys, ev_decomp = decomp_fn })
   = ASSERT( equalLength ptys (decomp_fn tm) )
-    mapM (newGivenEvVar loc)     -- See Note [Bind new Givens immediately]
-         (filterOut bad_given_pred (ptys `zip` decomp_fn tm))
+    do { given_evs <- mapM (newGivenEvVar loc) $    -- See Note [Bind new Givens immediately]
+                      filterOut bad_given_pred (ptys `zip` decomp_fn tm)
+       ; emitWorkNC given_evs }
   where
     -- See Note [Do not create Given kind equalities]
     bad_given_pred (pred_ty, _)
@@ -1732,22 +1702,46 @@ xCtEvidence (CtGiven { ctev_evtm = tm, ctev_loc = loc })
       | otherwise
       = False
 
-xCtEvidence (CtWanted { ctev_evar = evar, ctev_loc = loc })
-            (XEvTerm { ev_preds = ptys, ev_comp = comp_fn })
-  = do { new_evars <- mapM (newWantedEvVar loc) ptys
-       ; setEvBind evar (comp_fn (getEvTerms new_evars))
-       ; return (freshGoals new_evars) }
-
 xCtEvidence (CtDerived { ctev_loc = loc })
             (XEvTerm { ev_preds = ptys })
-  = do { ders <- mapM (newDerived loc) ptys
-       ; return (catMaybes ders) }
+  = mapM_ (emitNewDerived loc) ptys
 
 -----------------------------
+data StopOrContinue a
+  = ContinueWith a    -- The constraint was not solved, although it may have
+                      --   been rewritten
+
+  | Stop CtEvidence   -- The (rewritten) constraint was solved
+         SDoc         -- Tells how it was solved
+                      -- Any new sub-goals have been put on the work list
+
+instance Functor StopOrContinue where
+  fmap f (ContinueWith x) = ContinueWith (f x)
+  fmap _ (Stop ev s)      = Stop ev s
+
+instance Outputable a => Outputable (StopOrContinue a) where
+  ppr (Stop ev s)      = ptext (sLit "Stop") <> parens s <+> ppr ev
+  ppr (ContinueWith w) = ptext (sLit "ContinueWith") <+> ppr w
+
+continueWith :: a -> TcS (StopOrContinue a)
+continueWith = return . ContinueWith
+
+stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)
+stopWith ev s = return (Stop ev (text s))
+
+andWhenContinue :: TcS (StopOrContinue a)
+                -> (a -> TcS (StopOrContinue b))
+                -> TcS (StopOrContinue b)
+andWhenContinue tcs1 tcs2
+  = do { r <- tcs1
+       ; case r of
+           Stop ev s       -> return (Stop ev s)
+           ContinueWith ct -> tcs2 ct }
+
 rewriteEvidence :: CtEvidence   -- old evidence
                 -> TcPredType   -- new predicate
                 -> TcCoercion   -- Of type :: new predicate ~ <type of old evidence>
-                -> TcS (Maybe CtEvidence)
+                -> TcS (StopOrContinue CtEvidence)
 -- Returns Just new_ev iff either (i)  'co' is reflexivity
 --                             or (ii) 'co' is not reflexivity, and 'new_pred' not cached
 -- In either case, there is nothing new to do with new_ev
@@ -1782,7 +1776,7 @@ as well as in old_pred; that is important for good error messages.
  -}
 
 
-rewriteEvidence (CtDerived { ctev_loc = loc }) new_pred _co
+rewriteEvidence old_ev@(CtDerived { ctev_loc = loc }) new_pred _co
   = -- If derived, don't even look at the coercion.
     -- This is very important, DO NOT re-order the equations for
     -- rewriteEvidence to put the isTcReflCo test first!
@@ -1790,23 +1784,28 @@ rewriteEvidence (CtDerived { ctev_loc = loc }) new_pred _co
     -- was produced by flattening, may contain suspended calls to
     -- (ctEvTerm c), which fails for Derived constraints.
     -- (Getting this wrong caused Trac #7384.)
-    newDerived loc new_pred
+    do { mb_ev <- newDerived loc new_pred
+       ; case mb_ev of
+           Just new_ev -> continueWith new_ev
+           Nothing     -> stopWith old_ev "Cached derived" }
 
 rewriteEvidence old_ev new_pred co
   | isTcReflCo co -- See Note [Rewriting with Refl]
-  = return (Just (old_ev { ctev_pred = new_pred }))
+  = return (ContinueWith (old_ev { ctev_pred = new_pred }))
 
 rewriteEvidence (CtGiven { ctev_evtm = old_tm , ctev_loc = loc }) new_pred co
   = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)  -- See Note [Bind new Givens immediately]
-       ; return (Just new_ev) }
+       ; return (ContinueWith new_ev) }
   where
     new_tm = mkEvCast old_tm (mkTcSubCo (mkTcSymCo co))  -- mkEvCast optimises ReflCo
 
-rewriteEvidence (CtWanted { ctev_evar = evar, ctev_loc = loc }) new_pred co
-  = do { new_evar <- newWantedEvVar loc new_pred
+rewriteEvidence ev@(CtWanted { ctev_evar = evar, ctev_loc = loc }) new_pred co
+  = do { (new_ev, freshness) <- newWantedEvVar loc new_pred
        ; MASSERT( tcCoercionRole co == Nominal )
-       ; setEvBind evar (mkEvCast (getEvTerm new_evar) (mkTcSubCo co))
-       ; return (freshGoal new_evar) }
+       ; setEvBind evar (mkEvCast (ctEvTerm new_ev) (mkTcSubCo co))
+       ; case freshness of
+            Fresh  -> continueWith new_ev
+            Cached -> stopWith ev "Cached wanted" }
 
 
 rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)
@@ -1816,7 +1815,7 @@ rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swap
                                         -- Should be zonked, because we use typeKind on nlhs/nrhs
                   -> TcCoercion         -- lhs_co, of type :: nlhs ~ olhs
                   -> TcCoercion         -- rhs_co, of type :: nrhs ~ orhs
-                  -> TcS (Maybe CtEvidence)  -- Of type nlhs ~ nrhs
+                  -> TcS (StopOrContinue CtEvidence)  -- Of type nlhs ~ nrhs
 -- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co)
 -- we generate
 -- If not swapped
@@ -1834,29 +1833,33 @@ rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swap
 -- It's all a form of rewwriteEvidence, specialised for equalities
 rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
   | CtDerived { ctev_loc = loc } <- old_ev
-  = newDerived loc (mkTcEqPred nlhs nrhs)
+  = do { mb <- newDerived loc (mkTcEqPred nlhs nrhs)
+       ; case mb of 
+           Just new_ev -> continueWith new_ev
+           Nothing     -> stopWith old_ev "Cached derived" }
 
   | NotSwapped <- swapped
   , isTcReflCo lhs_co      -- See Note [Rewriting with Refl]
   , isTcReflCo rhs_co
-  = return (Just (old_ev { ctev_pred = new_pred }))
+  = return (ContinueWith (old_ev { ctev_pred = new_pred }))
 
   | CtGiven { ctev_evtm = old_tm , ctev_loc = loc } <- old_ev
   = do { let new_tm = EvCoercion (lhs_co 
                                   `mkTcTransCo` maybeSym swapped (evTermCoercion old_tm)
                                   `mkTcTransCo` mkTcSymCo rhs_co)
        ; new_ev <- newGivenEvVar loc (new_pred, new_tm)  -- See Note [Bind new Givens immediately]
-       ; return (Just new_ev) }
+       ; return (ContinueWith new_ev) }
 
   | CtWanted { ctev_evar = evar, ctev_loc = loc } <- old_ev
-  = do { new_evar <- newWantedEvVar loc new_pred
+  = do { new_evar <- newWantedEvVarNC loc new_pred
+                     -- Not much point in seeking exact-match equality evidence
        ; let co = maybeSym swapped $
                   mkTcSymCo lhs_co
-                  `mkTcTransCo` evTermCoercion (getEvTerm new_evar)
+                  `mkTcTransCo` ctEvCoercion new_evar
                   `mkTcTransCo` rhs_co
        ; setEvBind evar (EvCoercion co)
        ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])
-       ; return (freshGoal new_evar) }
+       ; return (ContinueWith new_evar) }
 
   | otherwise
   = panic "rewriteEvidence"
@@ -1900,6 +1903,17 @@ matchFam tycon args
 
 \end{code}
 
+Note [Residual implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The wl_implics in the WorkList are the residual implication
+constraints that are generated while solving or canonicalising the
+current worklist.  Specifically, when canonicalising
+   (forall a. t1 ~ forall a. t2) 
+from which we get the implication
+   (forall a. t1 ~ t2)
+See TcSMonad.deferTcSForAllEq
+
+
 \begin{code}
 -- Deferring forall equalities as implications
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1917,35 +1931,34 @@ deferTcSForAllEq role loc (tvs1,body1) (tvs2,body2)
             phi1 = Type.substTy subst1 body1
             phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2
             skol_info = UnifyForAllSkol skol_tvs phi1
-        ; mev <- newWantedEvVar loc $ case role of
-                Nominal ->          mkTcEqPred      phi1 phi2
-                Representational -> mkCoerciblePred phi1 phi2
-                Phantom ->          panic "deferTcSForAllEq Phantom"
-        ; coe_inside <- case mev of
-            Cached ev_tm -> return (evTermCoercion ev_tm)
-            Fresh ctev   -> do { ev_binds_var <- wrapTcS $ TcM.newTcEvBinds
-                               ; env <- wrapTcS $ TcM.getLclEnv
-                               ; let ev_binds = TcEvBinds ev_binds_var
-                                     new_ct = mkNonCanonical ctev
-                                     new_co = evTermCoercion (ctEvTerm ctev)
-                                     new_untch = pushUntouchables (tcl_untch env)
-                               ; let wc = WC { wc_flat  = singleCt new_ct
-                                             , wc_impl  = emptyBag
-                                             , wc_insol = emptyCts }
-                                     imp = Implic { ic_untch  = new_untch
-                                                  , ic_skols  = skol_tvs
-                                                  , ic_fsks   = []
-                                                  , ic_no_eqs = True
-                                                  , ic_given  = []
-                                                  , ic_wanted = wc
-                                                  , ic_insol  = False
-                                                  , ic_binds  = ev_binds_var
-                                                  , ic_env    = env
-                                                  , ic_info   = skol_info }
-                               ; updTcSImplics (consBag imp)
-                               ; return (TcLetCo ev_binds new_co) }
-
-        ; return $ EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs)
-        }
+            eq_pred   = case role of
+                          Nominal ->          mkTcEqPred      phi1 phi2
+                          Representational -> mkCoerciblePred phi1 phi2
+                          Phantom ->          panic "deferTcSForAllEq Phantom"
+        ; (ctev, freshness) <- newWantedEvVar loc eq_pred
+        ; coe_inside <- case freshness of
+            Cached -> return (ctEvCoercion ctev)
+            Fresh  -> do { ev_binds_var <- newTcEvBinds
+                         ; env <- wrapTcS $ TcM.getLclEnv
+                         ; let ev_binds = TcEvBinds ev_binds_var
+                               new_ct = mkNonCanonical ctev
+                               new_co = ctEvCoercion ctev
+                               new_untch = pushUntouchables (tcl_untch env)
+                         ; let wc = WC { wc_flat  = singleCt new_ct
+                                       , wc_impl  = emptyBag
+                                       , wc_insol = emptyCts }
+                               imp = Implic { ic_untch  = new_untch
+                                            , ic_skols  = skol_tvs
+                                            , ic_no_eqs = True
+                                            , ic_given  = []
+                                            , ic_wanted = wc
+                                            , ic_insol  = False
+                                            , ic_binds  = ev_binds_var
+                                            , ic_env    = env
+                                            , ic_info   = skol_info }
+                         ; updWorkListTcS (extendWorkListImplic imp)
+                         ; return (TcLetCo ev_binds new_co) }
+
+        ; return $ EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs) }
 \end{code}
 
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index e6da56667e..b13fdedc14 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -19,15 +19,15 @@ import TcMType as TcM
 import TcType
 import TcSMonad as TcS
 import TcInteract
-import Kind     ( isKind, defaultKind_maybe )
+import Kind     ( isKind, isSubKind, defaultKind_maybe )
 import Inst
 import Type     ( classifyPredType, isIPClass, PredTree(..), getClassPredTys_maybe )
 import TyCon    ( isSynFamilyTyCon )
 import Class    ( Class )
+import Id       ( idType )
 import Var
 import Unique
 import VarSet
-import VarEnv
 import TcEvidence
 import Name
 import Bag
@@ -60,7 +60,7 @@ simplifyTop :: WantedConstraints -> TcM (Bag EvBind)
 -- in a degenerate implication, so we do that here instead
 simplifyTop wanteds
   = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds
-       ; ev_binds_var <- newTcEvBinds
+       ; ev_binds_var <- TcM.newTcEvBinds
        ; zonked_final_wc <- solveWantedsTcMWithEvBinds ev_binds_var wanteds simpl_top
        ; binds1 <- TcRnMonad.getTcEvBinds ev_binds_var
        ; traceTc "End simplifyTop }" empty
@@ -74,7 +74,7 @@ simplifyTop wanteds
 simpl_top :: WantedConstraints -> TcS WantedConstraints
     -- See Note [Top-level Defaulting Plan]
 simpl_top wanteds
-  = do { wc_first_go <- nestTcS (solve_wanteds_and_drop wanteds)
+  = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds)
                             -- This is where the main work happens
        ; try_tyvar_defaulting wc_first_go }
   where
@@ -93,7 +93,7 @@ simpl_top wanteds
            ; if meta_tvs' == meta_tvs   -- No defaulting took place;
                                         -- (defaulting returns fresh vars)
              then try_class_defaulting wc
-             else do { wc_residual <- nestTcS (solve_wanteds_and_drop wc)
+             else do { wc_residual <- nestTcS (solveWantedsAndDrop wc)
                             -- See Note [Must simplify after defaulting]
                      ; try_class_defaulting wc_residual } }
 
@@ -105,7 +105,7 @@ simpl_top wanteds
       = do { something_happened <- applyDefaultingRules (approximateWC wc)
                                    -- See Note [Top-level Defaulting Plan]
            ; if something_happened
-             then do { wc_residual <- nestTcS (solve_wanteds_and_drop wc)
+             then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)
                      ; try_class_defaulting wc_residual }
              else return wc }
 \end{code}
@@ -191,7 +191,7 @@ More details in Note [DefaultTyVar].
 simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()
 simplifyAmbiguityCheck ty wanteds
   = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds)
-       ; ev_binds_var <- newTcEvBinds
+       ; ev_binds_var <- TcM.newTcEvBinds
        ; zonked_final_wc <- solveWantedsTcMWithEvBinds ev_binds_var wanteds simpl_top
        ; traceTc "End simplifyAmbiguityCheck }" empty
 
@@ -638,7 +638,7 @@ simplifyRule name lhs_wanted rhs_wanted
          (resid_wanted, _) <- solveWantedsTcM (lhs_wanted `andWC` rhs_wanted)
                               -- Post: these are zonked and unflattened
 
-       ; zonked_lhs_flats <- zonkCts (wc_flat lhs_wanted)
+       ; zonked_lhs_flats <- TcM.zonkFlats (wc_flat lhs_wanted)
        ; let (q_cts, non_q_cts) = partitionBag quantify_me zonked_lhs_flats
              quantify_me  -- Note [RULE quantification over equalities]
                | insolubleWC resid_wanted = quantify_insol
@@ -730,7 +730,7 @@ solveWantedsTcMWithEvBinds :: EvBindsVar
 solveWantedsTcMWithEvBinds ev_binds_var wc tcs_action
   = do { traceTc "solveWantedsTcMWithEvBinds" $ text "wanted=" <+> ppr wc
        ; wc2 <- runTcSWithEvBinds ev_binds_var (tcs_action wc)
-       ; zonkWC ev_binds_var wc2 }
+       ; zonkWC wc2 }
          -- See Note [Zonk after solving]
 
 solveWantedsTcM :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind)
@@ -739,22 +739,22 @@ solveWantedsTcM :: WantedConstraints -> TcM (WantedConstraints, Bag EvBind)
 -- Discards all Derived stuff in result
 -- Postcondition: fully zonked and unflattened constraints
 solveWantedsTcM wanted
-  = do { ev_binds_var <- newTcEvBinds
-       ; wanteds' <- solveWantedsTcMWithEvBinds ev_binds_var wanted solve_wanteds_and_drop
+  = do { ev_binds_var <- TcM.newTcEvBinds
+       ; wanteds' <- solveWantedsTcMWithEvBinds ev_binds_var wanted solveWantedsAndDrop
        ; binds <- TcRnMonad.getTcEvBinds ev_binds_var
        ; return (wanteds', binds) }
 
-solve_wanteds_and_drop :: WantedConstraints -> TcS (WantedConstraints)
--- Since solve_wanteds returns the residual WantedConstraints,
+solveWantedsAndDrop :: WantedConstraints -> TcS (WantedConstraints)
+-- Since solveWanteds returns the residual WantedConstraints,
 -- it should always be called within a runTcS or something similar,
-solve_wanteds_and_drop wanted = do { wc <- solve_wanteds wanted
-                                   ; return (dropDerivedWC wc) }
+solveWantedsAndDrop wanted = do { wc <- solveWanteds wanted
+                                ; return (dropDerivedWC wc) }
 
-solve_wanteds :: WantedConstraints -> TcS WantedConstraints
+solveWanteds :: WantedConstraints -> TcS WantedConstraints
 -- so that the inert set doesn't mindlessly propagate.
 -- NB: wc_flats may be wanted /or/ derived now
-solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols })
-  = do { traceTcS "solveWanteds {" (ppr wanted)
+solveWanteds wanteds
+  = do { traceTcS "solveWanteds {" (ppr wanteds)
 
          -- Try the flat bit, including insolubles. Solving insolubles a
          -- second time round is a bit of a waste; but the code is simple
@@ -762,57 +762,63 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols
          -- of adding Derived insolubles twice; see
          -- TcSMonad Note [Do not add duplicate derived insolubles]
        ; traceTcS "solveFlats {" empty
-       ; let all_flats = flats `unionBags` filterBag (not . isDerivedCt) insols
-             -- See Note [Dropping derived constraints] in TcRnTypes for
-             -- why the insolubles may have derived constraints
-
-       ; impls_from_flats <- solveInteract all_flats
-       ; traceTcS "solveFlats end }" (ppr impls_from_flats)
-
-       -- solve_wanteds iterates when it is able to float equalities
-       -- out of one or more of the implications.
-       ; unsolved_implics <- simpl_loop 1 (implics `unionBags` impls_from_flats)
-
-       ; (unsolved_flats, insoluble_flats) <- getInertUnsolved
+       ; solved_flats_wanteds <- solveFlats wanteds
+       ; traceTcS "solveFlats end }" (ppr solved_flats_wanteds)
 
-        -- We used to unflatten here but now we only do it once at top-level
-        -- during zonking -- see Note [Unflattening while zonking] in TcMType
-       ; let wc = WC { wc_flat  = unsolved_flats
-                     , wc_impl  = unsolved_implics
-                     , wc_insol = insoluble_flats }
+       -- solveWanteds iterates when it is able to float equalities
+       -- equalities out of one or more of the implications.
+       ; final_wanteds <- simpl_loop 1 solved_flats_wanteds
 
        ; bb <- getTcEvBindsMap
-       ; tb <- getTcSTyBindsMap
        ; traceTcS "solveWanteds }" $
-                 vcat [ text "unsolved_flats   =" <+> ppr unsolved_flats
-                      , text "unsolved_implics =" <+> ppr unsolved_implics
-                      , text "current evbinds  =" <+> ppr (evBindMapBinds bb)
-                      , text "current tybinds  =" <+> vcat (map ppr (varEnvElts tb))
-                      , text "final wc =" <+> ppr wc ]
-
-       ; return wc }
+                 vcat [ text "final wc =" <+> ppr final_wanteds
+                      , text "current evbinds  =" <+> ppr (evBindMapBinds bb) ]
+
+       ; return final_wanteds }
+
+solveFlats :: WantedConstraints -> TcS WantedConstraints
+-- Solve the wc_flat and wc_insol components of the WantedConstraints
+-- Do not affect the inerts
+solveFlats (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
+  = nestTcS $
+    do { let all_flats = flats `unionBags` filterBag (not . isDerivedCt) insols
+                     -- See Note [Dropping derived constraints] in TcRnTypes for
+                     -- why the insolubles may have derived constraints
+       ; wc <- solveFlatWanteds all_flats
+       ; return ( wc { wc_impl = implics `unionBags` wc_impl wc } ) }
 
 simpl_loop :: Int
-           -> Bag Implication
-           -> TcS (Bag Implication)
-simpl_loop n implics
+           -> WantedConstraints
+           -> TcS WantedConstraints
+simpl_loop n wanteds@(WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
   | n > 10
-  = traceTcS "solveWanteds: loop!" empty >> return implics
+  = do { traceTcS "solveWanteds: loop!" empty
+       ; return wanteds }
+
   | otherwise
   = do { traceTcS "simpl_loop, iteration" (int n)
        ; (floated_eqs, unsolved_implics) <- solveNestedImplications implics
+
        ; if isEmptyBag floated_eqs
-         then return unsolved_implics
+         then return (wanteds { wc_impl = unsolved_implics })
          else
+
     do {   -- Put floated_eqs into the current inert set before looping
-         (unifs_happened, impls_from_eqs) <- reportUnifications $
-                                             solveInteract floated_eqs
-       ; if   -- See Note [Cutting off simpl_loop]
-              isEmptyBag impls_from_eqs &&
-              not unifs_happened &&                 -- (a)
-              not (anyBag isCFunEqCan floated_eqs)  -- (b)
-         then return unsolved_implics
-         else simpl_loop (n+1) (unsolved_implics `unionBags` impls_from_eqs) } }
+         (unifs_happened, solve_flat_res) 
+             <- reportUnifications $
+                solveFlats (WC { wc_flat = floated_eqs `unionBags` flats
+                                 -- Put floated_eqs first so they get solved first
+                               , wc_insol = emptyBag, wc_impl = emptyBag })
+
+       ; let new_wanteds = solve_flat_res `andWC`
+                           WC { wc_flat  = emptyBag
+                              , wc_insol = insols
+                              , wc_impl  = unsolved_implics }
+
+       ; if   not unifs_happened   -- See Note [Cutting off simpl_loop]
+           && isEmptyBag (wc_impl solve_flat_res) 
+         then return new_wanteds
+         else simpl_loop (n+1) new_wanteds } }
 
 solveNestedImplications :: Bag Implication
                         -> TcS (Cts, Bag Implication)
@@ -822,16 +828,17 @@ solveNestedImplications implics
   | isEmptyBag implics
   = return (emptyBag, emptyBag)
   | otherwise
-  = do { inerts <- getTcSInerts
-       ; let thinner_inerts = prepareInertsForImplications inerts
-                 -- See Note [Preparing inert set for implications]
-
-       ; traceTcS "solveNestedImplications starting {" $
-         vcat [ text "original inerts = " <+> ppr inerts
-              , text "thinner_inerts  = " <+> ppr thinner_inerts ]
+  = do { 
+--         inerts <- getTcSInerts
+--       ; let thinner_inerts = prepareInertsForImplications inerts
+--                 -- See Note [Preparing inert set for implications]
+--
+           traceTcS "solveNestedImplications starting {" empty
+--           vcat [ text "original inerts = " <+> ppr inerts
+--                , text "thinner_inerts  = " <+> ppr thinner_inerts ]
 
        ; (floated_eqs, unsolved_implics)
-           <- flatMapBagPairM (solveImplication thinner_inerts) implics
+           <- flatMapBagPairM solveImplication implics
 
        -- ... and we are back in the original TcS inerts
        -- Notice that the original includes the _insoluble_flats so it was safe to ignore
@@ -842,45 +849,45 @@ solveNestedImplications implics
 
        ; return (floated_eqs, unsolved_implics) }
 
-solveImplication :: InertSet
-                 -> Implication    -- Wanted
+solveImplication :: Implication    -- Wanted
                  -> TcS (Cts,      -- All wanted or derived floated equalities: var = type
                          Bag Implication) -- Unsolved rest (always empty or singleton)
 -- Precondition: The TcS monad contains an empty worklist and given-only inerts
 -- which after trying to solve this implication we must restore to their original value
-solveImplication inerts
-     imp@(Implic { ic_untch  = untch
-                 , ic_binds  = ev_binds
-                 , ic_skols  = skols
-                 , ic_fsks   = old_fsks
-                 , ic_given  = givens
-                 , ic_wanted = wanteds
-                 , ic_info   = info
-                 , ic_env    = env })
-  = do { traceTcS "solveImplication {" (ppr imp)
+solveImplication imp@(Implic { ic_untch  = untch
+                             , ic_binds  = ev_binds
+                             , ic_skols  = skols
+                             , ic_given  = givens
+                             , ic_wanted = wanteds
+                             , ic_info   = info
+                             , ic_env    = env })
+  = do { inerts <- getTcSInerts
+       ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)
 
          -- Solve the nested constraints
-       ; (no_given_eqs, new_fsks, residual_wanted)
-            <- nestImplicTcS ev_binds untch inerts $
-               do { (no_eqs, new_fsks) <- solveInteractGiven (mkGivenLoc info env)
-                                                             old_fsks givens
+       ; (no_given_eqs, residual_wanted)
+             <- nestImplicTcS ev_binds untch $
+               do { solveFlatGivens (mkGivenLoc untch info env) givens
 
-                  ; residual_wanted <- solve_wanteds wanteds
-                        -- solve_wanteds, *not* solve_wanteds_and_drop, because
+                  ; residual_wanted <- solveWanteds wanteds
+                        -- solveWanteds, *not* solveWantedsAndDrop, because
                         -- we want to retain derived equalities so we can float
                         -- them out in floatEqualities
 
-                  ; return (no_eqs, new_fsks, residual_wanted) }
+                  ; no_eqs <- getNoGivenEqs untch skols
+
+                  ; return (no_eqs, residual_wanted) }
 
        ; (floated_eqs, final_wanted)
-             <- floatEqualities (skols ++ new_fsks) no_given_eqs residual_wanted
+             <- floatEqualities skols no_given_eqs residual_wanted
 
-       ; let res_implic | isEmptyWC final_wanted && no_given_eqs
+       ; let res_implic | isEmptyWC final_wanted -- && no_given_eqs
                         = emptyBag  -- Reason for the no_given_eqs: we don't want to
                                     -- lose the "inaccessible code" error message
+                                    -- BUT: final_wanted still has the derived insolubles
+                                    --      so it should be fine
                         | otherwise
-                        = unitBag (imp { ic_fsks   = new_fsks
-                                       , ic_no_eqs = no_given_eqs
+                        = unitBag (imp { ic_no_eqs = no_given_eqs
                                        , ic_wanted = dropDerivedWC final_wanted
                                        , ic_insol  = insolubleWC final_wanted })
 
@@ -888,7 +895,6 @@ solveImplication inerts
        ; traceTcS "solveImplication end }" $ vcat
              [ text "no_given_eqs =" <+> ppr no_given_eqs
              , text "floated_eqs =" <+> ppr floated_eqs
-             , text "new_fsks =" <+> ppr new_fsks
              , text "res_implic =" <+> ppr res_implic
              , text "implication evbinds = " <+> ppr (evBindMapBinds evbinds) ]
 
@@ -998,7 +1004,6 @@ approximateWC wc
       = emptyCts                      -- See Note [ApproximateWC]
       where
         new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp
-                                        `extendVarSetList` ic_fsks imp
     do_bag :: (a -> Bag c) -> Bag a -> Bag c
     do_bag f = foldrBag (unionBags.f) emptyBag
 \end{code}
@@ -1129,7 +1134,6 @@ beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs:
     data TEx where
       TEx :: a -> TEx
 
-
     f (x::beta) =
         let g1 :: forall b. b -> ()
             g1 _ = h [x]
@@ -1137,7 +1141,6 @@ beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs:
         in (g1 '3', g2 undefined)
 
 
-
 Note [Solving Family Equations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 After we are done with simplification we may be left with constraints of the form:
@@ -1213,112 +1216,74 @@ Consequence: classes with functional dependencies don't matter (since there is
 no evidence for a fundep equality), but equality superclasses do matter (since
 they carry evidence).
 
+
 \begin{code}
-floatEqualities :: [TcTyVar] -> Bool -> WantedConstraints
+floatEqualities :: [TcTyVar] -> Bool
+                -> WantedConstraints
                 -> TcS (Cts, WantedConstraints)
 -- Main idea: see Note [Float Equalities out of Implications]
 --
--- Post: The returned floated constraints (Cts) are only Wanted or Derived
--- and come from the input wanted ev vars or deriveds
+-- Precondition: the wc_flat of the incoming WantedConstraints are 
+--               fully zonked, so that we can see their free variables
+--
+-- Postcondition: The returned floated constraints (Cts) are only 
+--                Wanted or Derived and come from the input wanted 
+--                ev vars or deriveds
+--
 -- Also performs some unifications (via promoteTyVar), adding to
 -- monadically-carried ty_binds. These will be used when processing 
 -- floated_eqs later
 --
 -- Subtleties: Note [Float equalities from under a skolem binding]
 --             Note [Skolem escape]
-floatEqualities skols no_given_eqs wanteds@(WC { wc_flat = flats, wc_insol = insols })
+floatEqualities skols no_given_eqs wanteds@(WC { wc_flat = flats })
   | not no_given_eqs  -- There are some given equalities, so don't float
   = return (emptyBag, wanteds)   -- Note [Float Equalities out of Implications]
-  | not (isEmptyBag insols)
-  = return (emptyBag, wanteds)   -- Note [Do not float equalities if there are insolubles]
   | otherwise
-  = do { let (float_eqs, remaining_flats) = partitionBag is_floatable flats
-       ; untch <- TcS.getUntouchables
-       ; mapM_ (promoteTyVar untch) (varSetElems (tyVarsOfCts float_eqs))
+  = do { outer_untch <- TcS.getUntouchables
+       ; mapM_ (promoteTyVar outer_untch) (varSetElems (tyVarsOfCts float_eqs))
              -- See Note [Promoting unification variables]
-       ; ty_binds <- getTcSTyBindsMap
        ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols
                                           , text "Flats =" <+> ppr flats
-                                          , text "Skol set =" <+> ppr skol_set
-                                          , text "Floated eqs =" <+> ppr float_eqs
-                                          , text "Ty binds =" <+> ppr ty_binds])
+                                          , text "Floated eqs =" <+> ppr float_eqs ])
        ; return (float_eqs, wanteds { wc_flat = remaining_flats }) }
   where
-    is_floatable :: Ct -> Bool
-    is_floatable ct
-       = case classifyPredType (ctPred ct) of
-            EqPred ty1 ty2 -> skol_set `disjointVarSet` tyVarsOfType ty1
-                           && skol_set `disjointVarSet` tyVarsOfType ty2
-            _ -> False
-
-    skol_set = fixVarSet mk_next (mkVarSet skols)
-    mk_next tvs = foldr grow_one tvs flat_eqs
-    flat_eqs :: [(TcTyVarSet, TcTyVarSet)]
-    flat_eqs = [ (tyVarsOfType ty1, tyVarsOfType ty2)
-               | EqPred ty1 ty2 <- map (classifyPredType . ctPred) (bagToList flats)]
-    grow_one (tvs1,tvs2) tvs
-      | intersectsVarSet tvs tvs1 = tvs `unionVarSet` tvs2
-      | intersectsVarSet tvs tvs2 = tvs `unionVarSet` tvs2
-      | otherwise                 = tvs
+    skol_set = mkVarSet skols
+    (float_eqs, remaining_flats) = partitionBag float_me flats
+
+    float_me :: Ct -> Bool
+    float_me ct   -- The constraint is un-flattened and de-cannonicalised
+       | let pred = ctPred ct
+       , EqPred ty1 ty2 <- classifyPredType pred
+       , tyVarsOfType pred `disjointVarSet` skol_set
+       , useful_to_float ty1 ty2
+       = True
+       | otherwise
+       = False
+
+      -- Float out alpha ~ ty, or ty ~ alpha
+      -- which might be unified outside
+      -- See Note [Do not float kind-incompatible equalities]
+    useful_to_float ty1 ty2
+      = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of
+          (Just tv1, _) | isMetaTyVar tv1
+                        , k2 `isSubKind` k1
+                        -> True
+          (_, Just tv2) | isMetaTyVar tv2
+                        , k1 `isSubKind` k2
+                        -> True
+          _ -> False
+      where
+        k1 = typeKind ty1
+        k2 = typeKind ty2
 \end{code}
 
-Note [Do not float equalities if there are insolubles]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Do not float kind-incompatible equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If we have (t::* ~ s::*->*), we'll get a Derived insoluble equality.
 If we float the equality outwards, we'll get *another* Derived
 insoluble equality one level out, so the same error will be reported
-twice.  However, the equality is insoluble anyway, and when there are
-any insolubles we report only them, so there is no point in floating.
-
-
-Note [When does an implication have given equalities?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-     NB: This note is mainly referred to from TcSMonad
-         but it relates to floating equalities, so I've
-         left it here
-
-Consider an implication
-   beta => alpha ~ Int
-where beta is a unification variable that has already been unified
-to () in an outer scope.  Then we can float the (alpha ~ Int) out
-just fine. So when deciding whether the givens contain an equality,
-we should canonicalise first, rather than just looking at the original
-givens (Trac #8644).
-
-This is the entire reason for the inert_no_eqs field in InertCans.
-We initialise it to False before processing the Givens of an implication;
-and set it to True when adding an inert equality in addInertCan.
-
-However, 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 set the flag to False when adding an equality
-(TcSMonad.addInertCan) whose evidence whose CtOrigin is
-FlatSkolOrigin; see TcSMonad.isFlatSkolEv.  Note that we may transform
-the original flat-skol equality before adding it to the inerts, so
-it's important that the transformation preserves origin (which
-xCtEvidence and rewriteEvidence both do).  Example
-     instance F [a] = Maybe a
-     implication: C (F [a]) => blah
-  We flatten (C (F [a])) to C fsk, with <F [a]> : F [a] ~ fsk
-  Then we reduce the F [a] LHS, giving
-       g22 = ax7 ; <F [a]>
-       g22 : Maybe a ~ fsk
-  And before adding g22 we'll re-orient it to an ordinary tyvar
-  equality.  None of this should count as "adding a given equality".
-  This really happens (Trac #8651).
-
-An alternative we considered was to
-  * Accumulate the new inert equalities (in TcSMonad.addInertCan)
-  * In solveInteractGiven, check whether the evidence for the new
-    equalities mentions any of the ic_givens of this implication.
-This seems like the Right Thing, but it's more code, and more work
-at runtime, so we are using the FlatSkolOrigin idea intead. It's less
-obvious that it works, but I think it does, and it's simple and efficient.
+twice.  So we refrain from floating such equalities
 
 Note [Float equalities from under a skolem binding]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1327,72 +1292,21 @@ ones that don't mention the skolem-bound variables.  But that is
 over-eager. Consider
    [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int
 The second constraint doesn't mention 'a'.  But if we float it
-we'll promote gamma to gamma'[1].  Now suppose that we learn that
+we'll promote gamma[2] to gamma'[1].  Now suppose that we learn that
 beta := Bool, and F a Bool = a, and G Bool _ = Int.  Then we'll
 we left with the constraint
    [2] forall a. a ~ gamma'[1]
 which is insoluble because gamma became untouchable.
 
-Solution: only promote a constraint if its free variables cannot
-possibly be connected with the skolems.  Procedurally, start with
-the skolems and "grow" that set as follows:
-  * For each flat equality F ts ~ s, or tv ~ s,
-    if the current set intersects with the LHS of the equality,
-       add the free vars of the RHS, and vice versa
-That gives us a grown skolem set.  Now float an equality if its free
-vars don't intersect the grown skolem set.
-
-This seems very ad hoc (sigh).  But here are some tricky edge cases:
-
-a)    [2]forall a. (F a delta[1] ~ beta[2],   delta[1] ~ Maybe beta[2])
-b1)   [2]forall a. (F a ty ~ beta[2],         G beta[2] ~ gamma[2])
-b2)   [2]forall a. (a ~ beta[2],              G beta[2] ~ gamma[2])
-c)    [2]forall a. (F a ty ~ beta[2],         delta[1] ~ Maybe beta[2])
-d)    [2]forall a. (gamma[1] ~ Tree beta[2],  F ty ~ beta[2])
-
-In (a) we *must* float out the second equality,
-       else we can't solve at all (Trac #7804).
-
-In (b1, b2) we *must not* float out the second equality.
-       It will ultimately be solved (by flattening) in situ, but if we float
-       it we'll promote beta,gamma, and render the first equality insoluble.
-
-       Trac #9316 was an example of (b2).  You may wonder why (a ~ beta[2]) isn't
-       solved; in #9316 it wasn't solved because (a:*) and (beta:kappa[1]), so the
-       equality was kind-mismatched, and hence was a CIrredEvCan.  There was
-       another equality alongside, (kappa[1] ~ *).  We must first float *that*
-       one out and *then* we can solve (a ~ beta).
-
-In (c) it would be OK to float the second equality but better not to.
-       If we flatten we see (delta[1] ~ Maybe (F a ty)), which is a
-       skolem-escape problem.  If we float the second equality we'll
-       end up with (F a ty ~ beta'[1]), which is a less explicable error.
-
-In (d) we must float the first equality, so that we can unify gamma.
-       But that promotes beta, so we must float the second equality too,
-       Trac #7196 exhibits this case
-
-Some notes
-
-* When "growing", do not simply take the free vars of the predicate!
-  Example    [2]forall a.  (a:* ~ beta[2]:kappa[1]), (kappa[1] ~ *)
-  We must float the second, and we must not float the first.
-  But the first actually looks like ((~) kappa a beta), so if we just
-  look at its free variables we'll see {a,kappa,beta), and that might
-  make us think kappa should be in the grown skol set.
-
-  (In any case, the kind argument for a kind-mis-matched equality like
-   this one doesn't really make sense anyway.)
-
-  That's why we use classifyPred when growing.
-
-* Previously we tried to "grow" the skol_set with *all* the
-  constraints (not just equalities), to get all the tyvars that could
-  *conceivably* unify with the skolems, but that was far too
-  conservative (Trac #7804). Example: this should be fine:
-    f :: (forall a. a -> Proxy x -> Proxy (F x)) -> Int
-    f = error "Urk" :: (forall a. a -> Proxy x -> Proxy (F x)) -> Int
+Solution: float only constraints that stand a jolly good chance of
+being soluble simply by being floated, namely ones of form
+      a ~ ty
+where 'a' is a currently-untouchable unification variable, but may
+become touchable by being floated (perhaps by more than one level).
 
+We had a very complicated rule previously, but this is nice and
+simple.  (To see the notes, look at this Note in a version of
+TcSimplify prior to Oct 2014).
 
 Note [Skolem escape]
 ~~~~~~~~~~~~~~~~~~~~
@@ -1510,15 +1424,13 @@ disambigGroup []  _grp
   = return False
 disambigGroup (default_ty:default_tys) group
   = do { traceTcS "disambigGroup {" (ppr group $$ ppr default_ty)
-       ; success <- tryTcS $ -- Why tryTcS? If this attempt fails, we want to
-                             -- discard all side effects from the attempt
-                    do { setWantedTyBind the_tv default_ty
-                       ; implics_from_defaulting <- solveInteract wanteds
-                       ; MASSERT(isEmptyBag implics_from_defaulting)
-                           -- I am not certain if any implications can be generated
-                           -- but I am letting this fail aggressively if this ever happens.
-
-                       ; checkAllSolved }
+       ; fake_ev_binds_var <- TcS.newTcEvBinds
+       ; given_ev_var      <- TcS.newEvVar (mkTcEqPred (mkTyVarTy the_tv) default_ty)
+       ; untch             <- TcS.getUntouchables
+       ; success <- nestImplicTcS fake_ev_binds_var (pushUntouchables untch) $
+                    do { solveFlatGivens loc [given_ev_var]
+                       ; residual_wanted <- solveFlatWanteds wanteds
+                       ; return (isEmptyWC residual_wanted) }
 
        ; if success then
              -- Success: record the type variable binding, and return
@@ -1532,8 +1444,11 @@ disambigGroup (default_ty:default_tys) group
                            (ppr default_ty)
                 ; disambigGroup default_tys group } }
   where
-    ((_,_,the_tv):_) = group
     wanteds          = listToBag (map fstOf3 group)
+    ((_,_,the_tv):_) = group
+    loc = CtLoc { ctl_origin = GivenOrigin UnkSkol
+                , ctl_env = panic "disambigGroup:env"
+                , ctl_depth = initialSubGoalDepth }
 \end{code}
 
 Note [Avoiding spurious errors]
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index ffd3e070bb..a4a646c8e9 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -24,7 +24,8 @@ module TcType (
   TcTyVar, TcTyVarSet, TcKind, TcCoVar,
 
   -- Untouchables
-  Untouchables(..), noUntouchables, pushUntouchables, isTouchable,
+  Untouchables(..), noUntouchables, pushUntouchables, 
+  strictlyDeeperThan, sameDepthAs, fskUntouchables,
 
   --------------------------------
   -- MetaDetails
@@ -32,12 +33,14 @@ module TcType (
   TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,
   MetaDetails(Flexi, Indirect), MetaInfo(..),
   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,
-  isSigTyVar, isOverlappableTyVar,  isTyConableTyVar, isFlatSkolTyVar,
+  isSigTyVar, isOverlappableTyVar,  isTyConableTyVar, 
+  isFskTyVar, isFmvTyVar, isFlattenTyVar, 
   isAmbiguousTyVar, metaTvRef, metaTyVarInfo,
   isFlexi, isIndirect, isRuntimeUnkSkol,
   isTypeVar, isKindVar,
-  metaTyVarUntouchables, setMetaTyVarUntouchables,
-  isTouchableMetaTyVar, isFloatedTouchableMetaTyVar,
+  metaTyVarUntouchables, setMetaTyVarUntouchables, metaTyVarUntouchables_maybe,
+  isTouchableMetaTyVar, isTouchableOrFmv,
+  isFloatedTouchableMetaTyVar,
 
   --------------------------------
   -- Builders
@@ -274,17 +277,13 @@ data TcTyVarDetails
                   --          when looking up instances
                   -- See Note [Binding when looking up instances] in InstEnv
 
+  | FlatSkol      -- A flatten-skolem.  It stands for the TcType, and zonking
+       TcType     -- will replace it by that type.
+                  -- See Note [The flattening story] in TcFlatten
+
   | RuntimeUnk    -- Stands for an as-yet-unknown type in the GHCi
                   -- interactive context
 
-  | FlatSkol TcType
-           -- The "skolem" obtained by flattening during
-           -- constraint simplification
-
-           -- In comments we will use the notation alpha[flat = ty]
-           -- to represent a flattening skolem variable alpha
-           -- identified with type ty.
-
   | MetaTv { mtv_info  :: MetaInfo
            , mtv_ref   :: IORef MetaDetails
            , mtv_untch :: Untouchables }  -- See Note [Untouchable type variables]
@@ -317,6 +316,10 @@ data MetaInfo
                    --      The MetaDetails, if filled in, will
                    --      always be another SigTv or a SkolemTv
 
+   | FlatMetaTv    -- A flatten meta-tyvar
+                   -- It is a meta-tyvar, but it is always untouchable, with level 0
+                   -- See Note [The flattening story] in TcFlatten
+
 -------------------------------------
 -- UserTypeCtxt describes the origin of the polymorphic type
 -- in the places where we need to an expression has that type
@@ -420,30 +423,34 @@ The same idea of only unifying touchables solves another problem.
 Suppose we had
    (F Int ~ uf[0])  /\  [1](forall a. C a => F Int ~ beta[1])
 In this example, beta is touchable inside the implication. The
-first solveInteract step leaves 'uf' un-unified. Then we move inside
+first solveFlatWanteds step leaves 'uf' un-unified. Then we move inside
 the implication where a new constraint
        uf  ~  beta
 emerges. If we (wrongly) spontaneously solved it to get uf := beta,
 the whole implication disappears but when we pop out again we are left with
-(F Int ~ uf) which will be unified by our final solveCTyFunEqs stage and
+(F Int ~ uf) which will be unified by our final zonking stage and
 uf will get unified *once more* to (F Int).
 
 \begin{code}
-newtype Untouchables = Untouchables Int
+newtype Untouchables = Untouchables Int deriving( Eq )
   -- See Note [Untouchable type variables] for what this Int is
 
+fskUntouchables :: Untouchables
+fskUntouchables = Untouchables 0  -- 0 = Outside the outermost level: 
+                                  --     flatten skolems
+
 noUntouchables :: Untouchables
-noUntouchables = Untouchables 0   -- 0 = outermost level
+noUntouchables = Untouchables 1   -- 1 = outermost level
 
 pushUntouchables :: Untouchables -> Untouchables
 pushUntouchables (Untouchables us) = Untouchables (us+1)
 
-isFloatedTouchable :: Untouchables -> Untouchables -> Bool
-isFloatedTouchable (Untouchables ctxt_untch) (Untouchables tv_untch)
-  = ctxt_untch < tv_untch
+strictlyDeeperThan :: Untouchables -> Untouchables -> Bool
+strictlyDeeperThan (Untouchables tv_untch) (Untouchables ctxt_untch)
+  = tv_untch > ctxt_untch
 
-isTouchable :: Untouchables -> Untouchables -> Bool
-isTouchable (Untouchables ctxt_untch) (Untouchables tv_untch)
+sameDepthAs :: Untouchables -> Untouchables -> Bool
+sameDepthAs (Untouchables ctxt_untch) (Untouchables tv_untch)
   = ctxt_untch == tv_untch   -- NB: invariant ctxt_untch >= tv_untch
                              --     So <= would be equivalent
 
@@ -471,12 +478,13 @@ pprTcTyVarDetails (SkolemTv False) = ptext (sLit "sk")
 pprTcTyVarDetails (RuntimeUnk {})  = ptext (sLit "rt")
 pprTcTyVarDetails (FlatSkol {})    = ptext (sLit "fsk")
 pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_untch = untch })
-  = pp_info <> brackets (ppr untch)
+  = pp_info <> colon <> ppr untch
   where
     pp_info = case info of
-                PolyTv -> ptext (sLit "poly")
-                TauTv  -> ptext (sLit "tau")
-                SigTv  -> ptext (sLit "sig")
+                PolyTv     -> ptext (sLit "poly")
+                TauTv      -> ptext (sLit "tau")
+                SigTv      -> ptext (sLit "sig")
+                FlatMetaTv -> ptext (sLit "fuv")
 
 pprUserTypeCtxt :: UserTypeCtxt -> SDoc
 pprUserTypeCtxt (InfSigCtxt n)    = ptext (sLit "the inferred type for") <+> quotes (ppr n)
@@ -583,6 +591,18 @@ exactTyVarsOfTypes = mapUnionVarSet exactTyVarsOfType
 %************************************************************************
 
 \begin{code}
+isTouchableOrFmv :: Untouchables -> TcTyVar -> Bool
+isTouchableOrFmv ctxt_untch tv
+  = ASSERT2( isTcTyVar tv, ppr tv )
+    case tcTyVarDetails tv of
+      MetaTv { mtv_untch = tv_untch, mtv_info = info }
+        -> ASSERT2( checkTouchableInvariant ctxt_untch tv_untch,
+                    ppr tv $$ ppr tv_untch $$ ppr ctxt_untch )
+           case info of
+             FlatMetaTv -> True
+             _          -> tv_untch `sameDepthAs` ctxt_untch
+      _          -> False
+
 isTouchableMetaTyVar :: Untouchables -> TcTyVar -> Bool
 isTouchableMetaTyVar ctxt_untch tv
   = ASSERT2( isTcTyVar tv, ppr tv )
@@ -590,14 +610,14 @@ isTouchableMetaTyVar ctxt_untch tv
       MetaTv { mtv_untch = tv_untch }
         -> ASSERT2( checkTouchableInvariant ctxt_untch tv_untch,
                     ppr tv $$ ppr tv_untch $$ ppr ctxt_untch )
-           isTouchable ctxt_untch tv_untch
+           tv_untch `sameDepthAs` ctxt_untch
       _ -> False
 
 isFloatedTouchableMetaTyVar :: Untouchables -> TcTyVar -> Bool
 isFloatedTouchableMetaTyVar ctxt_untch tv
   = ASSERT2( isTcTyVar tv, ppr tv )
     case tcTyVarDetails tv of
-      MetaTv { mtv_untch = tv_untch } -> isFloatedTouchable ctxt_untch tv_untch
+      MetaTv { mtv_untch = tv_untch } -> tv_untch `strictlyDeeperThan` ctxt_untch
       _ -> False
 
 isImmutableTyVar :: TyVar -> Bool
@@ -606,7 +626,8 @@ isImmutableTyVar tv
   | otherwise    = True
 
 isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
-  isMetaTyVar, isAmbiguousTyVar, isFlatSkolTyVar :: TcTyVar -> Bool
+  isMetaTyVar, isAmbiguousTyVar, 
+  isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool
 
 isTyConableTyVar tv
         -- True of a meta-type variable that can be filled in
@@ -617,7 +638,22 @@ isTyConableTyVar tv
         MetaTv { mtv_info = SigTv } -> False
         _                           -> True
 
-isFlatSkolTyVar tv
+isFmvTyVar tv
+  = ASSERT2( isTcTyVar tv, ppr tv )
+    case tcTyVarDetails tv of
+        MetaTv { mtv_info = FlatMetaTv } -> True
+        _                                -> False
+
+-- | True of both given and wanted flatten-skolems (fak and usk)
+isFlattenTyVar tv
+  = ASSERT2( isTcTyVar tv, ppr tv )
+    case tcTyVarDetails tv of
+        FlatSkol {}                      -> True
+        MetaTv { mtv_info = FlatMetaTv } -> True
+        _                                -> False
+
+-- | True of FlatSkol skolems only
+isFskTyVar tv
   = ASSERT2( isTcTyVar tv, ppr tv )
     case tcTyVarDetails tv of
         FlatSkol {} -> True
@@ -626,10 +662,8 @@ isFlatSkolTyVar tv
 isSkolemTyVar tv
   = ASSERT2( isTcTyVar tv, ppr tv )
     case tcTyVarDetails tv of
-        SkolemTv {}   -> True
-        FlatSkol {}   -> True
-        RuntimeUnk {} -> True
-        MetaTv {}     -> False
+        MetaTv {} -> False
+        _other    -> True
 
 isOverlappableTyVar tv
   = ASSERT( isTcTyVar tv )
@@ -673,6 +707,13 @@ metaTyVarUntouchables tv
       MetaTv { mtv_untch = untch } -> untch
       _ -> pprPanic "metaTyVarUntouchables" (ppr tv)
 
+metaTyVarUntouchables_maybe :: TcTyVar -> Maybe Untouchables
+metaTyVarUntouchables_maybe tv
+  = ASSERT( isTcTyVar tv )
+    case tcTyVarDetails tv of
+      MetaTv { mtv_untch = untch } -> Just untch
+      _                            -> Nothing
+
 setMetaTyVarUntouchables :: TcTyVar -> Untouchables -> TcTyVar
 setMetaTyVarUntouchables tv untch
   = ASSERT( isTcTyVar tv )
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 389c4a3142..f5033ee08a 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -451,7 +451,6 @@ newImplication skol_info skol_tvs given thing_inside
        ; env <- getLclEnv
        ; emitImplication $ Implic { ic_untch = untch
                                   , ic_skols = skol_tvs
-                                  , ic_fsks  = []
                                   , ic_no_eqs = False
                                   , ic_given = given
                                   , ic_wanted = wanted