Taming the Kind Inference Monster
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 28 Nov 2018 16:06:15 +0000 (16:06 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 29 Nov 2018 17:27:40 +0000 (17:27 +0000)
My original goal was (Trac #15809) to move towards using level numbers
as the basis for deciding which type variables to generalise, rather
than searching for the free varaibles of the environment.  However
it has turned into a truly major refactoring of the kind inference
engine.

Let's deal with the level-numbers part first:

* Augment quantifyTyVars to calculate the type variables to
  quantify using level numbers, and compare the result with
  the existing approach.  That is; no change in behaviour,
  just a WARNing if the two approaches give different answers.

* To do this I had to get the level number right when calling
  quantifyTyVars, and this entailed a bit of care, especially
  in the code for kind-checking type declarations.

* However, on the way I was able to eliminate or simplify
  a number of calls to solveEqualities.

This work is incomplete: I'm not /using/ level numbers yet.
When I subsequently get rid of any remaining WARNings in
quantifyTyVars, that the level-number answers differ from
the current answers, then I can rip out the current
"free vars of the environment" stuff.

Anyway, this led me into deep dive into kind inference for type and
class declarations, which is an increasingly soggy part of GHC.
Richard already did some good work recently in

   commit 5e45ad10ffca1ad175b10f6ef3327e1ed8ba25f3
   Date:   Thu Sep 13 09:56:02 2018 +0200

    Finish fix for #14880.

    The real change that fixes the ticket is described in
    Note [Naughty quantification candidates] in TcMType.

but I kept turning over stones. So this patch has ended up
with a pretty significant refactoring of that code too.

Kind inference for types and classes
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

* Major refactoring in the way we generalise the inferred kind of
  a TyCon, in kcTyClGroup.  Indeed, I made it into a new top-level
  function, generaliseTcTyCon.  Plus a new Note to explain it
  Note [Inferring kinds for type declarations].

* We decided (Trac #15592) not to treat class type variables specially
  when dealing with Inferred/Specified/Required for associated types.
  That simplifies things quite a bit. I also rewrote
  Note [Required, Specified, and Inferred for types]

* Major refactoring of the crucial function kcLHsQTyVars:
  I split it into
       kcLHsQTyVars_Cusk  and  kcLHsQTyVars_NonCusk
  because the two are really quite different. The CUSK case is
  almost entirely rewritten, and is much easier because of our new
  decision not to treat the class variables specially

* I moved all the error checks from tcTyClTyVars (which was a bizarre
  place for it) into generaliseTcTyCon and/or the CUSK case of
  kcLHsQTyVars.  Now tcTyClTyVars is extremely simple.

* I got rid of all the all the subtleties in tcImplicitTKBndrs. Indeed
  now there is no difference between tcImplicitTKBndrs and
  kcImplicitTKBndrs; there is now a single bindImplicitTKBndrs.
  Same for kc/tcExplicitTKBndrs.  None of them monkey with level
  numbers, nor build implication constraints.  scopeTyVars is gone
  entirely, as is kcLHsQTyVarBndrs. It's vastly simpler.

  I found I could get rid of kcLHsQTyVarBndrs entirely, in favour of
  the bnew bindExplicitTKBndrs.

Quantification
~~~~~~~~~~~~~~
* I now deal with the "naughty quantification candidates"
  of the previous patch in candidateQTyVars, rather than in
  quantifyTyVars; see Note [Naughty quantification candidates]
  in TcMType.

  I also killed off closeOverKindsCQTvs in favour of the same
  strategy that we use for tyCoVarsOfType: namely, close over kinds
  at the occurrences.

  And candidateQTyVars no longer needs a gbl_tvs argument.

* Passing the ContextKind, rather than the expected kind itself,
  to tc_hs_sig_type_and_gen makes it easy to allocate the expected
  result kind (when we are in inference mode) at the right level.

Type families
~~~~~~~~~~~~~~
* I did a major rewrite of the impenetrable tcFamTyPats. The result
  is vastly more comprehensible.

* I got rid of kcDataDefn entirely, quite a big function.

* I re-did the way that checkConsistentFamInst works, so
  that it allows alpha-renaming of invisible arguments.

* The interaction of kind signatures and family instances is tricky.
    Type families: see Note [Apparently-nullary families]
    Data families: see Note [Result kind signature for a data family instance]
                   and Note [Eta-reduction for data families]

* The consistent instantation of an associated type family is tricky.
  See Note [Checking consistent instantiation] and
      Note [Matching in the consistent-instantation check]
  in TcTyClsDecls.  It's now checked in TcTyClsDecls because that is
  when we have the relevant info to hand.

* I got tired of the compromises in etaExpandFamInst, so I did the
  job properly by adding a field cab_eta_tvs to CoAxBranch.
  See Coercion.etaExpandCoAxBranch.

tcInferApps and friends
~~~~~~~~~~~~~~~~~~~~~~~
* I got rid of the mysterious and horrible ClsInstInfo argument
  to tcInferApps, checkExpectedKindX, and various checkValid
  functions.  It was horrible!

* I got rid of [Type] result of tcInferApps.  This list was used
  only in tcFamTyPats, when checking the LHS of a type instance;
  and if there is a cast in the middle, the list is meaningless.
  So I made tcInferApps simpler, and moved the complexity
  (not much) to tcInferApps.

  Result: tcInferApps is now pretty comprehensible again.

* I refactored the many function in TcMType that instantiate skolems.

Smaller things

* I rejigged the error message in checkValidTelescope; I think it's
  quite a bit better now.

* checkValidType was not rejecting constraints in a kind signature
     forall (a :: Eq b => blah). blah2
  That led to further errors when we then do an ambiguity check.
  So I make checkValidType reject it more aggressively.

* I killed off quantifyConDecl, instead calling kindGeneralize
  directly.

* I fixed an outright bug in tyCoVarsOfImplic, where we were not
  colleting the tyvar of the kind of the skolems

* Renamed ClsInstInfo to AssocInstInfo, and made it into its
  own data type

* Some fiddling around with pretty-printing of family
  instances which was trickier than I thought.  I wanted
  wildcards to print as plain "_" in user messages, although
  they each need a unique identity in the CoAxBranch.

Some other oddments

* Refactoring around the trace messages from reportUnsolved.
* A bit of extra tc-tracing in TcHsSyn.commitFlexi

This patch fixes a raft of bugs, and includes tests for them.

 * #14887
 * #15740
 * #15764
 * #15789
 * #15804
 * #15817
 * #15870
 * #15874
 * #15881

157 files changed:
compiler/basicTypes/DataCon.hs
compiler/basicTypes/OccName.hs
compiler/basicTypes/VarEnv.hs
compiler/coreSyn/CoreLint.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsTypes.hs
compiler/iface/IfaceSyn.hs
compiler/iface/MkIface.hs
compiler/iface/TcIface.hs
compiler/nativeGen/CFG.hs
compiler/parser/RdrHsSyn.hs
compiler/prelude/TysPrim.hs
compiler/typecheck/ClsInst.hs
compiler/typecheck/FamInst.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcBackpack.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcClassDcl.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcDerivInfer.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcGenGenerics.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcMType.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcRules.hs
compiler/typecheck/TcSMonad.hs
compiler/typecheck/TcSigs.hs
compiler/typecheck/TcSimplify.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcUnify.hs
compiler/typecheck/TcValidity.hs
compiler/types/CoAxiom.hs
compiler/types/Coercion.hs
compiler/types/FamInstEnv.hs
compiler/types/TyCoRep.hs
compiler/types/TyCon.hs
compiler/types/Type.hs
compiler/types/Type.hs-boot
compiler/types/Unify.hs
compiler/utils/FastString.hs
compiler/utils/Util.hs
testsuite/tests/dependent/should_compile/T15743.stderr
testsuite/tests/dependent/should_compile/T15743e.stderr
testsuite/tests/dependent/should_fail/BadTelescope.stderr
testsuite/tests/dependent/should_fail/BadTelescope3.stderr
testsuite/tests/dependent/should_fail/BadTelescope4.stderr
testsuite/tests/dependent/should_fail/T13895.stderr
testsuite/tests/dependent/should_fail/T14066f.stderr
testsuite/tests/dependent/should_fail/T14066g.stderr
testsuite/tests/dependent/should_fail/T15591b.stderr
testsuite/tests/dependent/should_fail/T15591c.stderr
testsuite/tests/dependent/should_fail/T15743c.stderr
testsuite/tests/dependent/should_fail/T15743d.stderr
testsuite/tests/ghci/scripts/T10059.stdout
testsuite/tests/ghci/scripts/T15591.hs
testsuite/tests/ghci/scripts/T15591.stdout
testsuite/tests/ghci/scripts/T15743b.stdout
testsuite/tests/ghci/scripts/T6018ghcifail.stderr
testsuite/tests/ghci/scripts/T7873.stderr
testsuite/tests/ghci/scripts/ghci059.stdout
testsuite/tests/indexed-types/should_compile/T15711.stderr
testsuite/tests/indexed-types/should_compile/T15740a.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_compile/T15764a.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_compile/T15852.stderr
testsuite/tests/indexed-types/should_compile/T3017.stderr
testsuite/tests/indexed-types/should_compile/all.T
testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4a.stderr
testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.hs
testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr
testsuite/tests/indexed-types/should_fail/SimpleFail13.stderr
testsuite/tests/indexed-types/should_fail/SimpleFail2a.hs
testsuite/tests/indexed-types/should_fail/SimpleFail2a.stderr
testsuite/tests/indexed-types/should_fail/SimpleFail9.hs
testsuite/tests/indexed-types/should_fail/SimpleFail9.stderr
testsuite/tests/indexed-types/should_fail/T10817.stderr
testsuite/tests/indexed-types/should_fail/T10899.stderr
testsuite/tests/indexed-types/should_fail/T11450.stderr
testsuite/tests/indexed-types/should_fail/T12041.stderr
testsuite/tests/indexed-types/should_fail/T13092/T13092.stderr
testsuite/tests/indexed-types/should_fail/T13092c/T13092c.stderr
testsuite/tests/indexed-types/should_fail/T13972.hs
testsuite/tests/indexed-types/should_fail/T13972.stderr [deleted file]
testsuite/tests/indexed-types/should_fail/T14045a.hs
testsuite/tests/indexed-types/should_fail/T14045a.stderr [deleted file]
testsuite/tests/indexed-types/should_fail/T14179.stderr
testsuite/tests/indexed-types/should_fail/T14887.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/T14887.stderr [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/T15740.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/T15740.stderr [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/T15764.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/T15764.stderr [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/T15870.hs [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/T15870.stderr [new file with mode: 0644]
testsuite/tests/indexed-types/should_fail/T7536.stderr
testsuite/tests/indexed-types/should_fail/T7938.hs
testsuite/tests/indexed-types/should_fail/T7938.stderr
testsuite/tests/indexed-types/should_fail/T9160.stderr
testsuite/tests/indexed-types/should_fail/all.T
testsuite/tests/partial-sigs/should_compile/ADT.stderr
testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr
testsuite/tests/partial-sigs/should_compile/Meltdown.stderr
testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr
testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr
testsuite/tests/partial-sigs/should_compile/SkipMany.stderr
testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr
testsuite/tests/partial-sigs/should_fail/T14040a.stderr
testsuite/tests/polykinds/T11203.stderr
testsuite/tests/polykinds/T11821a.stderr
testsuite/tests/polykinds/T12593.stderr
testsuite/tests/polykinds/T13985.hs
testsuite/tests/polykinds/T13985.stderr
testsuite/tests/polykinds/T14450.stderr
testsuite/tests/polykinds/T14846.stderr
testsuite/tests/polykinds/T14887a.hs [new file with mode: 0644]
testsuite/tests/polykinds/T14887a.stderr [new file with mode: 0644]
testsuite/tests/polykinds/T15592.stderr
testsuite/tests/polykinds/T15592b.stderr
testsuite/tests/polykinds/T15789.hs [new file with mode: 0644]
testsuite/tests/polykinds/T15789.stderr [new file with mode: 0644]
testsuite/tests/polykinds/T15804.hs [new file with mode: 0644]
testsuite/tests/polykinds/T15804.stderr [new file with mode: 0644]
testsuite/tests/polykinds/T15817.hs [new file with mode: 0644]
testsuite/tests/polykinds/T15874.hs [new file with mode: 0644]
testsuite/tests/polykinds/T15881.hs [new file with mode: 0644]
testsuite/tests/polykinds/T15881.stderr [new file with mode: 0644]
testsuite/tests/polykinds/T15881a.hs [new file with mode: 0644]
testsuite/tests/polykinds/T15881a.stderr [new file with mode: 0644]
testsuite/tests/polykinds/T8616.stderr
testsuite/tests/polykinds/all.T
testsuite/tests/roles/should_compile/Roles1.stderr
testsuite/tests/roles/should_compile/Roles14.stderr
testsuite/tests/roles/should_compile/Roles2.stderr
testsuite/tests/roles/should_compile/Roles3.stderr
testsuite/tests/roles/should_compile/Roles4.stderr
testsuite/tests/roles/should_compile/T8958.stderr
testsuite/tests/showIface/Orphans.stdout
testsuite/tests/th/TH_Roles2.stderr
testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
testsuite/tests/typecheck/should_compile/T12763.stderr
testsuite/tests/typecheck/should_compile/tc231.stderr
testsuite/tests/typecheck/should_fail/LevPolyBounded.stderr
testsuite/tests/typecheck/should_fail/T13983.stderr
testsuite/tests/typecheck/should_fail/T14607.hs
testsuite/tests/typecheck/should_fail/T14607.stderr
testsuite/tests/typecheck/should_fail/T2688.stderr
testsuite/tests/typecheck/should_fail/T6018fail.stderr
testsuite/tests/typecheck/should_fail/all.T

index b7435e5..de4fd12 100644 (file)
@@ -74,6 +74,7 @@ import Class
 import Name
 import PrelNames
 import Var
+import VarSet( emptyVarSet )
 import Outputable
 import Util
 import BasicTypes
@@ -1487,7 +1488,7 @@ buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
   = mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta
                rhs parent gadt_syn
   where
-    binders = mkTyConBindersPreferAnon ktvs liftedTypeKind
+    binders = mkTyConBindersPreferAnon ktvs emptyVarSet
 
 buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind   -- ^ /result/ kind
               -> [Role] -> KnotTied Type -> TyCon
index 3032c0c..b474c64 100644 (file)
@@ -859,9 +859,10 @@ avoidClashesOccEnv env occs = go env emptyUFM occs
 tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
 tidyOccName env occ@(OccName occ_sp fs)
   | not (fs `elemUFM` env)
-    && (fs /= fsLit "_")
-        -- See Note [Always number wildcard types when tidying]
-  = (addToUFM env fs 1, occ)   -- Desired OccName is free
+  = -- Desired OccName is free, so use it,
+    -- and record in 'env' that it's no longer available
+    (addToUFM env fs 1, occ)
+
   | otherwise
   = case lookupUFM env base1 of
        Nothing -> (addToUFM env base1 2, OccName occ_sp base1)
@@ -887,33 +888,6 @@ tidyOccName env occ@(OccName occ_sp fs)
                      -- If they are the same (n==1), the former wins
                      -- See Note [TidyOccEnv]
 
-{-
-Note [Always number wildcard types when tidying]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the following example (from the DataFamilyInstanceLHS test case):
-
-  data family Sing (a :: k)
-  data instance Sing (_ :: MyKind) where
-      SingA :: Sing A
-      SingB :: Sing B
-
-If we're not careful during tidying, then when this program is compiled with
--ddump-types, we'll get the following information:
-
-  COERCION AXIOMS
-    axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 ::
-      Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _
-
-Yikes! We shouldn't have a wildcard type appearing on the RHS like that. To
-avoid this issue, during tidying, we always opt to add a numeric suffix to
-types that are simply `_`. That way, you instead end up with:
-
-  COERCION AXIOMS
-    axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 ::
-      Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1
-
-Which is at least legal syntax.
--}
 
 {-
 ************************************************************************
index 3e48447..b2ab8d8 100644 (file)
@@ -70,7 +70,7 @@ module VarEnv (
 
         -- * TidyEnv and its operation
         TidyEnv,
-        emptyTidyEnv
+        emptyTidyEnv, mkEmptyTidyEnv
     ) where
 
 import GhcPrelude
@@ -402,6 +402,9 @@ type TidyEnv = (TidyOccEnv, VarEnv Var)
 emptyTidyEnv :: TidyEnv
 emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
 
+mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv
+mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv)
+
 {-
 ************************************************************************
 *                                                                      *
index d5f5f39..8ab0fbf 100644 (file)
@@ -1958,11 +1958,12 @@ lintCoercion co@(AxiomInstCo con ind cos)
                                       (zip3 (ktvs ++ cvs) roles cos)
        ; let lhs' = substTys subst_l lhs
              rhs' = substTy  subst_r rhs
+             fam_tc = coAxiomTyCon con
        ; case checkAxInstCo co of
            Just bad_branch -> bad_ax $ text "inconsistent with" <+>
-                                       pprCoAxBranch con bad_branch
+                                       pprCoAxBranch fam_tc bad_branch
            Nothing -> return ()
-       ; let s2 = mkTyConApp (coAxiomTyCon con) lhs'
+       ; let s2 = mkTyConApp fam_tc lhs'
        ; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) }
   where
     bad_ax what = addErrL (hang (text  "Bad axiom application" <+> parens what)
index 0ff36aa..246f8f9 100644 (file)
@@ -37,7 +37,8 @@ module HsDecls (
   -- ** Instance declarations
   InstDecl(..), LInstDecl, FamilyInfo(..),
   TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
-  DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprFamInstLHS,
+  DataFamInstDecl(..), LDataFamInstDecl,
+  pprDataFamInstFlavour, pprHsFamInstLHS,
   FamInstEqn, LFamInstEqn, FamEqn(..),
   TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
   HsTyPats,
@@ -701,7 +702,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where
     ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
                  , tcdRhs = rhs })
       = hang (text "type" <+>
-              pp_vanilla_decl_head ltycon tyvars fixity [] <+> equals)
+              pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> equals)
           4 (ppr rhs)
 
     ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity
@@ -723,8 +724,9 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where
                                      pprLHsBindsForUser methods sigs) ]
       where
         top_matter = text "class"
-                    <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context)
+                    <+> pp_vanilla_decl_head lclas tyvars fixity context
                     <+> pprFundeps (map unLoc fds)
+
     ppr (XTyClDecl x) = ppr x
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
@@ -743,10 +745,10 @@ pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p))
    => Located (IdP (GhcPass p))
    -> LHsQTyVars (GhcPass p)
    -> LexicalFixity
-   -> HsContext (GhcPass p)
+   -> LHsContext (GhcPass p)
    -> SDoc
 pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
- = hsep [pprHsContext context, pp_tyvars tyvars]
+ = hsep [pprLHsContext context, pp_tyvars tyvars]
   where
     pp_tyvars (varl:varsr)
       | fixity == Infix && length varsr > 1
@@ -1109,7 +1111,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
                                     , fdResultSig = L _ result
                                     , fdInjectivityAnn = mb_inj })
   = vcat [ pprFlavour info <+> pp_top_level <+>
-           pp_vanilla_decl_head ltycon tyvars fixity [] <+>
+           pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+>
            pp_kind <+> pp_inj <+> pp_where
          , nest 2 $ pp_eqns ]
   where
@@ -1399,10 +1401,10 @@ hsConDeclTheta Nothing            = []
 hsConDeclTheta (Just (L _ theta)) = theta
 
 pp_data_defn :: (OutputableBndrId (GhcPass p))
-                  => (HsContext (GhcPass p) -> SDoc)   -- Printing the header
+                  => (LHsContext (GhcPass p) -> SDoc)   -- Printing the header
                   -> HsDataDefn (GhcPass p)
                   -> SDoc
-pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
+pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context
                                 , dd_cType = mb_ct
                                 , dd_kindSig = mb_sig
                                 , dd_cons = condecls, dd_derivs = derivings })
@@ -1453,7 +1455,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con
                                    : map (pprHsType . unLoc) tys)
     ppr_details (RecCon fields)  = pprPrefixOcc con
                                  <+> pprConDeclFields (unLoc fields)
-    cxt = fromMaybe (noLoc []) mcxt
+    cxt = fromMaybe noLHsContext mcxt
 
 pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
                         , con_mb_cxt = mcxt, con_args = args
@@ -1466,7 +1468,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
     get_args (RecCon fields)  = [pprConDeclFields (unLoc fields)]
     get_args (InfixCon {})    = pprPanic "pprConDecl:GADT" (ppr cons)
 
-    cxt = fromMaybe (noLoc []) mcxt
+    cxt = fromMaybe noLHsContext mcxt
 
     ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
     ppr_arrow_chain []     = empty
@@ -1704,12 +1706,12 @@ ppr_instance_keyword NotTopLevel = empty
 
 ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p))
                  => TyFamInstEqn (GhcPass p) -> SDoc
-ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
+ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon  = L _ tycon
                                             , feqn_bndrs  = bndrs
                                             , feqn_pats   = pats
                                             , feqn_fixity = fixity
                                             , feqn_rhs    = rhs }})
-    = pprFamInstLHS tycon bndrs pats fixity [] Nothing <+> equals <+> ppr rhs
+    = pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs
 ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x
 ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x
 
@@ -1719,7 +1721,7 @@ ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon  = tycon
                                , feqn_pats   = tvs
                                , feqn_fixity = fixity
                                , feqn_rhs    = rhs }))
-    = text "type" <+> pp_vanilla_decl_head tycon tvs fixity []
+    = text "type" <+> pp_vanilla_decl_head tycon tvs fixity noLHsContext
                   <+> equals <+> ppr rhs
 ppr_fam_deflt_eqn (L _ (XFamEqn x)) = ppr x
 
@@ -1730,7 +1732,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
 pprDataFamInstDecl :: (OutputableBndrId (GhcPass p))
                    => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc
 pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
-                             FamEqn { feqn_tycon  = tycon
+                             FamEqn { feqn_tycon  = L _ tycon
                                     , feqn_bndrs  = bndrs
                                     , feqn_pats   = pats
                                     , feqn_fixity = fixity
@@ -1738,10 +1740,9 @@ pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
   = pp_data_defn pp_hdr defn
   where
     pp_hdr ctxt = ppr_instance_keyword top_lvl
-              <+> pprFamInstLHS tycon bndrs pats fixity ctxt Nothing
-                    -- No need to pass an explicit kind signature to
-                    -- pprFamInstLHS here, since pp_data_defn already
-                    -- pretty-prints that. See #14817.
+              <+> pprHsFamInstLHS tycon bndrs pats fixity ctxt
+                  -- pp_data_defn pretty-prints the kind sig. See #14817.
+
 pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x)))
   = ppr x
 pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x))
@@ -1759,35 +1760,28 @@ pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x)))
 pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x))
   = ppr x
 
-pprFamInstLHS :: (OutputableBndrId (GhcPass p))
-   => Located (IdP (GhcPass p))
+pprHsFamInstLHS :: (OutputableBndrId (GhcPass p))
+   => IdP (GhcPass p)
    -> Maybe [LHsTyVarBndr (GhcPass p)]
    -> HsTyPats (GhcPass p)
    -> LexicalFixity
-   -> HsContext (GhcPass p)
-   -> Maybe (LHsKind (GhcPass p))
+   -> LHsContext (GhcPass p)
    -> SDoc
-pprFamInstLHS thing bndrs typats fixity context mb_kind_sig
-                                              -- explicit type patterns
-   = hsep [ pprHsContext context, pprHsExplicitForAll bndrs
-          , pp_pats typats, pp_kind_sig ]
+pprHsFamInstLHS thing bndrs typats fixity mb_ctxt
+   = hsep [ pprHsExplicitForAll bndrs
+          , pprLHsContext mb_ctxt
+          , pp_pats typats ]
    where
      pp_pats (patl:patr:pats)
        | Infix <- fixity
-       = let pp_op_app = hsep [ ppr patl, pprInfixOcc (unLoc thing), ppr patr ] in
+       = let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in
          case pats of
            [] -> pp_op_app
            _  -> hsep (parens pp_op_app : map ppr pats)
 
-     pp_pats pats = hsep [ pprPrefixOcc (unLoc thing)
+     pp_pats pats = hsep [ pprPrefixOcc thing
                          , hsep (map ppr pats)]
 
-     pp_kind_sig
-       | Just k <- mb_kind_sig
-       = dcolon <+> ppr k
-       | otherwise
-       = empty
-
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (ClsInstDecl p) where
     ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
index bc909cf..993b020 100644 (file)
@@ -24,7 +24,7 @@ module HsTypes (
         HsWildCardBndrs(..),
         LHsSigType, LHsSigWcType, LHsWcType,
         HsTupleSort(..),
-        HsContext, LHsContext,
+        HsContext, LHsContext, noLHsContext,
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
 
@@ -63,7 +63,7 @@ module HsTypes (
 
         -- Printing
         pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll,
-        pprHsContext, pprHsContextNoArrow, pprHsContextMaybe,
+        pprLHsContext,
         hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext
     ) where
 
@@ -90,7 +90,6 @@ import FastString
 import Maybes( isJust )
 
 import Data.Data hiding ( Fixity, Prefix, Infix )
-import Data.Maybe ( fromMaybe )
 
 {-
 ************************************************************************
@@ -264,9 +263,16 @@ quantified in left-to-right order in kind signatures is nice since:
 -- | Located Haskell Context
 type LHsContext pass = Located (HsContext pass)
       -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit'
-
       -- For details on above see note [Api annotations] in ApiAnnotation
 
+noLHsContext :: LHsContext pass
+-- Use this when there is no context in the original program
+-- It would really be more kosher to use a Maybe, to distinguish
+--     class () => C a where ...
+-- from
+--     class C a where ...
+noLHsContext = noLoc []
+
 -- | Haskell Context
 type HsContext pass = [LHsType pass]
 
@@ -1126,7 +1132,7 @@ splitLHsForAllTy body              = ([], body)
 splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)
 splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty
 splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt,     body)
-splitLHsQualTy body              = (noLoc [], body)
+splitLHsQualTy body              = (noLHsContext, body)
 
 splitLHsInstDeclTy :: LHsSigType GhcRn
                    -> ([Name], LHsContext GhcRn, LHsType GhcRn)
@@ -1307,7 +1313,7 @@ pprHsForAllExtra :: (OutputableBndrId (GhcPass p))
                  => Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)]
                  -> LHsContext (GhcPass p) -> SDoc
 pprHsForAllExtra extra qtvs cxt
-  = pp_forall <+> pprHsContextExtra (isJust extra) (unLoc cxt)
+  = pp_forall <+> pprLHsContextExtra (isJust extra) cxt
   where
     pp_forall | null qtvs = whenPprDebug (forAllLit <> dot)
               | otherwise = forAllLit <+> interppSP qtvs <> dot
@@ -1319,36 +1325,28 @@ pprHsExplicitForAll :: (OutputableBndrId (GhcPass p))
 pprHsExplicitForAll (Just qtvs) = forAllLit <+> interppSP qtvs <> dot
 pprHsExplicitForAll Nothing     = empty
 
-pprHsContext :: (OutputableBndrId (GhcPass p)) => HsContext (GhcPass p) -> SDoc
-pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
-
-pprHsContextNoArrow :: (OutputableBndrId (GhcPass p))
-                    => HsContext (GhcPass p) -> SDoc
-pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
-
-pprHsContextMaybe :: (OutputableBndrId (GhcPass p))
-                  => HsContext (GhcPass p) -> Maybe SDoc
-pprHsContextMaybe []         = Nothing
-pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred
-pprHsContextMaybe cxt        = Just $ parens (interpp'SP cxt)
+pprLHsContext :: (OutputableBndrId (GhcPass p))
+              => LHsContext (GhcPass p) -> SDoc
+pprLHsContext lctxt
+  | null (unLoc lctxt) = empty
+  | otherwise          = pprLHsContextAlways lctxt
 
 -- For use in a HsQualTy, which always gets printed if it exists.
-pprHsContextAlways :: (OutputableBndrId (GhcPass p))
-                   => HsContext (GhcPass p) -> SDoc
-pprHsContextAlways []  = parens empty <+> darrow
-pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow
-pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow
+pprLHsContextAlways :: (OutputableBndrId (GhcPass p))
+                    => LHsContext (GhcPass p) -> SDoc
+pprLHsContextAlways (L _ ctxt)
+  = case ctxt of
+      []       -> parens empty             <+> darrow
+      [L _ ty] -> ppr_mono_ty ty           <+> darrow
+      _        -> parens (interpp'SP ctxt) <+> darrow
 
 -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
-pprHsContextExtra :: (OutputableBndrId (GhcPass p))
-                  => Bool -> HsContext (GhcPass p) -> SDoc
-pprHsContextExtra show_extra ctxt
-  | not show_extra
-  = pprHsContext ctxt
-  | null ctxt
-  = char '_' <+> darrow
-  | otherwise
-  = parens (sep (punctuate comma ctxt')) <+> darrow
+pprLHsContextExtra :: (OutputableBndrId (GhcPass p))
+                   => Bool -> LHsContext (GhcPass p) -> SDoc
+pprLHsContextExtra show_extra lctxt@(L _ ctxt)
+  | not show_extra = pprLHsContext lctxt
+  | null ctxt      = char '_' <+> darrow
+  | otherwise      = parens (sep (punctuate comma ctxt')) <+> darrow
   where
     ctxt' = map ppr ctxt ++ [char '_']
 
@@ -1386,10 +1384,10 @@ ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
 
 ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
 ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
-  = sep [pprHsForAll tvs (noLoc []), ppr_mono_lty ty]
+  = sep [pprHsForAll tvs noLHsContext, ppr_mono_lty ty]
 
-ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
-  = sep [pprHsContextAlways ctxt, ppr_mono_lty ty]
+ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })
+  = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty]
 
 ppr_mono_ty (HsBangTy _ b ty)   = ppr b <> ppr_mono_lty ty
 ppr_mono_ty (HsRecTy _ flds)      = pprConDeclFields flds
index 2e63fbc..1bf4ca9 100644 (file)
@@ -211,12 +211,13 @@ data IfaceAT = IfaceAT  -- See Class.ClassATItem
 
 
 -- This is just like CoAxBranch
-data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars   :: [IfaceTvBndr]
-                                   , ifaxbCoVars   :: [IfaceIdBndr]
-                                   , ifaxbLHS      :: IfaceAppArgs
-                                   , ifaxbRoles    :: [Role]
-                                   , ifaxbRHS      :: IfaceType
-                                   , ifaxbIncomps  :: [BranchIndex] }
+data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars    :: [IfaceTvBndr]
+                                   , ifaxbEtaTyVars :: [IfaceTvBndr]
+                                   , ifaxbCoVars    :: [IfaceIdBndr]
+                                   , ifaxbLHS       :: IfaceAppArgs
+                                   , ifaxbRoles     :: [Role]
+                                   , ifaxbRHS       :: IfaceType
+                                   , ifaxbIncomps   :: [BranchIndex] }
                                      -- See Note [Storing compatibility] in CoAxiom
 
 data IfaceConDecls
@@ -556,11 +557,19 @@ pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc
 -- The TyCon might be local (just an OccName), or this might
 -- be a branch for an imported TyCon, so it would be an ExtName
 -- So it's easier to take an SDoc here
+--
+-- This function is used
+--    to print interface files,
+--    in debug messages
+--    in :info F for GHCi, which goes via toConToIfaceDecl on the family tycon
+-- For user error messages we use Coercion.pprCoAxiom and friends
 pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs
+                                 , ifaxbCoVars = _cvs
                                  , ifaxbLHS = pat_tys
                                  , ifaxbRHS = rhs
                                  , ifaxbIncomps = incomps })
-  = hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs))
+  = WARN( not (null _cvs), pp_tc $$ ppr _cvs )
+    hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs))
     $+$
     nest 2 maybe_incomps
   where
@@ -890,10 +899,9 @@ pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
 
 pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon
                            , ifAxBranches = branches })
-  = hang (text "axiom" <+> ppr name <> dcolon)
+  = hang (text "axiom" <+> ppr name <+> dcolon)
        2 (vcat $ map (pprAxBranch (ppr tycon)) branches)
 
-
 pprCType :: Maybe CType -> SDoc
 pprCType Nothing      = Outputable.empty
 pprCType (Just cType) = text "C type:" <+> ppr cType
@@ -1073,13 +1081,14 @@ instance Outputable IfaceRule where
   ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
                    ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
                    ifRuleOrph = orph })
-    = sep [hsep [pprRuleName name,
-                 if isOrphan orph then text "[orphan]" else Outputable.empty,
-                 ppr act,
-                 text "forall" <+> pprIfaceBndrs bndrs],
-           nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
-                        text "=" <+> ppr rhs])
-      ]
+    = sep [ hsep [ pprRuleName name
+                 , if isOrphan orph then text "[orphan]" else Outputable.empty
+                 , ppr act
+                 , pp_foralls ]
+          , nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
+                        text "=" <+> ppr rhs]) ]
+    where
+      pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot
 
 instance Outputable IfaceClsInst where
   ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag
@@ -1856,13 +1865,14 @@ instance Binary IfaceAT where
         return (IfaceAT dec defs)
 
 instance Binary IfaceAxBranch where
-    put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6) = do
+    put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do
         put_ bh a1
         put_ bh a2
         put_ bh a3
         put_ bh a4
         put_ bh a5
         put_ bh a6
+        put_ bh a7
     get bh = do
         a1 <- get bh
         a2 <- get bh
@@ -1870,7 +1880,8 @@ instance Binary IfaceAxBranch where
         a4 <- get bh
         a5 <- get bh
         a6 <- get bh
-        return (IfaceAxBranch a1 a2 a3 a4 a5 a6)
+        a7 <- get bh
+        return (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7)
 
 instance Binary IfaceConDecls where
     put_ bh IfAbstractTyCon  = putByte bh 0
index e3d1b82..acd6c46 100644 (file)
@@ -22,6 +22,7 @@ module MkIface (
         RecompileRequired(..), recompileRequired,
         mkIfaceExports,
 
+        coAxiomToIfaceDecl,
         tyThingToIfaceDecl -- Converting things to their Iface equivalents
  ) where
 
@@ -1634,18 +1635,16 @@ coAxBranchToIfaceBranch tc lhs_s
 -- use this one for standalone branches without incompatibles
 coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
 coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
+                                        , cab_eta_tvs = eta_tvs
                                         , cab_lhs = lhs
                                         , cab_roles = roles, cab_rhs = rhs })
-  = IfaceAxBranch { ifaxbTyVars  = toIfaceTvBndrs tidy_tvs
-                  , ifaxbCoVars  = map toIfaceIdBndr cvs
-                  , ifaxbLHS     = tidyToIfaceTcArgs env1 tc lhs
-                  , ifaxbRoles   = roles
-                  , ifaxbRHS     = tidyToIfaceType env1 rhs
-                  , ifaxbIncomps = [] }
-  where
-    (env1, tidy_tvs) = tidyVarBndrs emptyTidyEnv tvs
-    -- Don't re-bind in-scope tyvars
-    -- See Note [CoAxBranch type variables] in CoAxiom
+  = IfaceAxBranch { ifaxbTyVars    = toIfaceTvBndrs tvs
+                  , ifaxbCoVars    = map toIfaceIdBndr cvs
+                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs
+                  , ifaxbLHS       = toIfaceTcArgs tc lhs
+                  , ifaxbRoles     = roles
+                  , ifaxbRHS       = toIfaceType rhs
+                  , ifaxbIncomps   = [] }
 
 -----------------
 tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
@@ -1708,6 +1707,7 @@ tyConToIfaceDecl env tycon
     (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
     tc_tyvars      = binderVars tc_binders
     if_binders     = toIfaceTyCoVarBinders tc_binders
+                     -- No tidying of the binders; they are already tidy
     if_res_kind    = tidyToIfaceType tc_env1 (tyConResKind tycon)
     if_syn_type ty = tidyToIfaceType tc_env1 ty
     if_res_var     = getOccFS `fmap` tyConFamilyResVar_maybe tycon
@@ -1718,19 +1718,16 @@ tyConToIfaceDecl env tycon
                                                    (tidyToIfaceTcArgs tc_env1 tc ty)
                Nothing           -> IfNoParent
 
-    to_if_fam_flav OpenSynFamilyTyCon        = IfaceOpenSynFamilyTyCon
+    to_if_fam_flav OpenSynFamilyTyCon             = IfaceOpenSynFamilyTyCon
+    to_if_fam_flav AbstractClosedSynFamilyTyCon   = IfaceAbstractClosedSynFamilyTyCon
+    to_if_fam_flav (DataFamilyTyCon {})           = IfaceDataFamilyTyCon
+    to_if_fam_flav (BuiltInSynFamTyCon {})        = IfaceBuiltInSynFamTyCon
+    to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing
     to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
       = IfaceClosedSynFamilyTyCon (Just (axn, ibr))
       where defs = fromBranches $ coAxiomBranches ax
             ibr  = map (coAxBranchToIfaceBranch' tycon) defs
             axn  = coAxiomName ax
-    to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
-      = IfaceClosedSynFamilyTyCon Nothing
-    to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
-    to_if_fam_flav (DataFamilyTyCon {})         = IfaceDataFamilyTyCon
-    to_if_fam_flav (BuiltInSynFamTyCon {})      = IfaceBuiltInSynFamTyCon
-
-
 
     ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)
     ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
index 34bcdb7..29893ca 100644 (file)
@@ -857,17 +857,24 @@ tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
 
 tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
 tc_ax_branch prev_branches
-             (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs
+             (IfaceAxBranch { ifaxbTyVars = tv_bndrs
+                            , ifaxbEtaTyVars = eta_tv_bndrs
+                            , ifaxbCoVars = cv_bndrs
                             , ifaxbLHS = lhs, ifaxbRHS = rhs
                             , ifaxbRoles = roles, ifaxbIncomps = incomps })
   = bindIfaceTyConBinders_AT
       (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
          -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
     bindIfaceIds cv_bndrs $ \ cvs -> do
-    { tc_lhs <- tcIfaceAppArgs lhs
-    ; tc_rhs <- tcIfaceType rhs
-    ; let br = CoAxBranch { cab_loc     = noSrcSpan
+    { tc_lhs   <- tcIfaceAppArgs lhs
+    ; tc_rhs   <- tcIfaceType rhs
+    ; eta_tvs  <- bindIfaceTyVars eta_tv_bndrs return
+    ; this_mod <- getIfModule
+    ; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS`
+                                  moduleNameFS (moduleName this_mod))
+          br = CoAxBranch { cab_loc     = loc
                           , cab_tvs     = binderVars tvs
+                          , cab_eta_tvs = eta_tvs
                           , cab_cvs     = cvs
                           , cab_lhs     = tc_lhs
                           , cab_roles   = roles
@@ -1768,6 +1775,13 @@ bindIfaceTyVar (occ,kind) thing_inside
         ; tyvar <- mk_iface_tyvar name kind
         ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
 
+bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
+bindIfaceTyVars [] thing_inside = thing_inside []
+bindIfaceTyVars (bndr:bndrs) thing_inside
+  = bindIfaceTyVar bndr   $ \tv  ->
+    bindIfaceTyVars bndrs $ \tvs ->
+    thing_inside (tv : tvs)
+
 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
 mk_iface_tyvar name ifKind
    = do { kind <- tcIfaceType ifKind
index 8207859..b5b0fd7 100644 (file)
@@ -489,7 +489,6 @@ getCfgProc weights (CmmProc _info _lab _live graph)
   | null (toBlockList graph) = mapEmpty
   | otherwise                = getCfg weights graph
 
-
 getCfg :: D.CfgWeights -> CmmGraph -> CFG
 getCfg weights graph =
   foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks
index 8c78fb5..9712034 100644 (file)
@@ -871,12 +871,12 @@ equalsDots = text "= ..."
 
 checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
 checkDatatypeContext Nothing = return ()
-checkDatatypeContext (Just (dL->L loc c))
+checkDatatypeContext (Just c)
     = do allowed <- extension datatypeContextsEnabled
          unless allowed $
-             parseErrorSDoc loc
-                 (text "Illegal datatype context (use DatatypeContexts):" <+>
-                  pprHsContext c)
+             parseErrorSDoc (getLoc c)
+                 (text "Illegal datatype context (use DatatypeContexts):"
+                  <+> pprLHsContext c)
 
 type LRuleTyTmVar = Located RuleTyTmVar
 data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))
index 4147cff..10034de 100644 (file)
@@ -255,12 +255,17 @@ mkTemplateKindVars :: [Kind] -> [TyVar]
 -- k0  with unique (mkAlphaTyVarUnique 0)
 -- k1  with unique (mkAlphaTyVarUnique 1)
 -- ... etc
+mkTemplateKindVars [kind]
+  = [mkTyVar (mk_tv_name 0 "k") kind]
+    -- Special case for one kind: just "k"
+
 mkTemplateKindVars kinds
-  = [ mkTyVar name kind
-    | (kind, u) <- kinds `zip` [0..]
-    , let occ = mkTyVarOccFS (mkFastString ('k' : show u))
-          name = mkInternalName (mkAlphaTyVarUnique u) occ noSrcSpan
-    ]
+  = [ mkTyVar (mk_tv_name u ('k' : show u)) kind
+    | (kind, u) <- kinds `zip` [0..] ]
+mk_tv_name :: Int -> String -> Name
+mk_tv_name u s = mkInternalName (mkAlphaTyVarUnique u)
+                                (mkTyVarOccFS (mkFastString s))
+                                noSrcSpan
 
 mkTemplateTyVarsFrom :: Int -> [Kind] -> [TyVar]
 -- a  with unique (mkAlphaTyVarUnique n)
@@ -275,9 +280,7 @@ mkTemplateTyVarsFrom n kinds
       let ch_ord = index + ord 'a'
           name_str | ch_ord <= ord 'z' = [chr ch_ord]
                    | otherwise         = 't':show index
-          uniq = mkAlphaTyVarUnique (index + n)
-          name = mkInternalName uniq occ noSrcSpan
-          occ  = mkTyVarOccFS (mkFastString name_str)
+          name = mk_tv_name (index + n) name_str
     ]
 
 mkTemplateTyVars :: [Kind] -> [TyVar]
index 37057a1..c777c4b 100644 (file)
@@ -3,7 +3,8 @@
 module ClsInst (
      matchGlobalInst,
      ClsInstResult(..),
-     InstanceWhat(..), safeOverlap
+     InstanceWhat(..), safeOverlap,
+     AssocInstInfo(..), isNotAssociated
   ) where
 
 #include "HsVersions.h"
@@ -30,6 +31,7 @@ import Type
 import MkCore ( mkStringExprFS, mkNaturalExpr )
 
 import Name   ( Name )
+import VarEnv ( VarEnv )
 import DataCon
 import TyCon
 import Class
@@ -40,6 +42,30 @@ import Data.Maybe
 
 {- *******************************************************************
 *                                                                    *
+              A helper for associated types within
+              class instance declarations
+*                                                                    *
+**********************************************************************-}
+
+-- | Extra information about the parent instance declaration, needed
+-- when type-checking associated types. The 'Class' is the enclosing
+-- class, the [TyVar] are the /scoped/ type variable of the instance decl.
+-- The @VarEnv Type@ maps class variables to their instance types.
+data AssocInstInfo
+  = NotAssociated
+  | InClsInst { ai_class    :: Class
+              , ai_tyvars   :: [TyVar]      -- ^ The /scoped/ tyvars of the instance
+              , ai_inst_env :: VarEnv Type  -- ^ Maps /class/ tyvars to their instance types
+                -- See Note [Matching in the consistent-instantation check]
+    }
+
+isNotAssociated :: AssocInstInfo -> Bool
+isNotAssociated NotAssociated  = True
+isNotAssociated (InClsInst {}) = False
+
+
+{- *******************************************************************
+*                                                                    *
                        Class lookup
 *                                                                    *
 **********************************************************************-}
index 100919e..623d465 100644 (file)
@@ -696,14 +696,13 @@ environments (one for the EPS and one for the HPT).
 checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool
 checkForConflicts inst_envs fam_inst
   = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst
-             no_conflicts = null conflicts
        ; traceTc "checkForConflicts" $
          vcat [ ppr (map fim_instance conflicts)
               , ppr fam_inst
               -- , ppr inst_envs
          ]
-       ; unless no_conflicts $ conflictInstErr fam_inst conflicts
-       ; return no_conflicts }
+       ; reportConflictInstErr fam_inst conflicts
+       ; return (null conflicts) }
 
 -- | Check whether a new open type family equation can be added without
 -- violating injectivity annotation supplied by the user. Returns True when
@@ -739,9 +738,9 @@ makeInjectivityErrors fi_ax axiom inj conflicts
   = ASSERT2( any id inj, text "No injective type variables" )
     let lhs             = coAxBranchLHS axiom
         rhs             = coAxBranchRHS axiom
-
+        fam_tc          = coAxiomTyCon fi_ax
         are_conflicts   = not $ null conflicts
-        unused_inj_tvs  = unusedInjTvsInRHS (coAxiomTyCon fi_ax) inj lhs rhs
+        unused_inj_tvs  = unusedInjTvsInRHS fam_tc inj lhs rhs
         inj_tvs_unused  = not $ and (isEmptyVarSet <$> unused_inj_tvs)
         tf_headed       = isTFHeaded rhs
         bare_variables  = bareTvInRHSViolated lhs rhs
@@ -749,7 +748,7 @@ makeInjectivityErrors fi_ax axiom inj conflicts
 
         err_builder herald eqns
                         = ( hang herald
-                               2 (vcat (map (pprCoAxBranch fi_ax) eqns))
+                               2 (vcat (map (pprCoAxBranchUser fam_tc) eqns))
                           , coAxBranchSpan (head eqns) )
         errorIf p f     = if p then [f err_builder axiom] else []
      in    errorIf are_conflicts  (conflictInjInstErr     conflicts     )
@@ -850,16 +849,6 @@ bareTvInRHSViolated pats rhs | isTyVarTy rhs
 bareTvInRHSViolated _ _ = []
 
 
-conflictInstErr :: FamInst -> [FamInstMatch] -> TcRn ()
-conflictInstErr fam_inst conflictingMatch
-  | (FamInstMatch { fim_instance = confInst }) : _ <- conflictingMatch
-  = let (err, span) = makeFamInstsErr
-                            (text "Conflicting family instance declarations:")
-                            [fam_inst, confInst]
-    in setSrcSpan span $ addErr err
-  | otherwise
-  = panic "conflictInstErr"
-
 -- | Type of functions that use error message and a list of axioms to build full
 -- error message (with a source location) for injective type families.
 type InjErrorBuilder = SDoc -> [CoAxBranch] -> (SDoc, SrcSpan)
@@ -933,18 +922,21 @@ bareVariableInRHSErr tys errorBuilder famInst
                   text "variables:" <+> pprQuotedList tys) [famInst]
 
 
-makeFamInstsErr :: SDoc -> [FamInst] -> (SDoc, SrcSpan)
-makeFamInstsErr herald insts
-  = ASSERT( not (null insts) )
-    ( hang herald
-         2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) 0
-                 | fi <- sorted ])
-    , srcSpan )
+reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn ()
+reportConflictInstErr _ []
+  = return ()  -- No conflicts
+reportConflictInstErr fam_inst (match1 : _)
+  | FamInstMatch { fim_instance = conf_inst } <- match1
+  , let sorted  = sortWith getSpan [fam_inst, conf_inst]
+        fi1     = head sorted
+        span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))
+  = setSrcSpan span $ addErr $
+    hang (text "Conflicting family instance declarations:")
+       2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)
+               | fi <- sorted
+               , let ax = famInstAxiom fi ])
  where
    getSpan = getSrcLoc . famInstAxiom
-   sorted  = sortWith getSpan insts
-   fi1     = head sorted
-   srcSpan = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))
    -- The sortWith just arranges that instances are dislayed in order
    -- of source location, which reduced wobbling in error messages,
    -- and is better for users
index 4f380d3..afc6370 100644 (file)
@@ -484,17 +484,28 @@ no longer cut it, but it seems fine for now.
 -}
 
 ---------------------------
--- | This is used to instantiate binders when type-checking *types* only.
--- The @VarEnv Kind@ gives some known instantiations.
+-- | Instantantiate the TyConBinders of a forall type,
+--   given its decomposed form (tvs, ty)
+tcInstTyBinders :: HasDebugCallStack
+              => ([TyCoBinder], TcKind)   -- ^ The type (forall bs. ty)
+              -> TcM ([TcType], TcKind)   -- ^ Instantiated bs, substituted ty
+-- Takes a pair because that is what splitPiTysInvisible returns
 -- See also Note [Bidirectional type checking]
-tcInstTyBinders :: TCvSubst -> Maybe (VarEnv Kind)
-                -> [TyBinder] -> TcM (TCvSubst, [TcType])
-tcInstTyBinders subst mb_kind_info bndrs
-  = do { (subst, args) <- mapAccumLM (tcInstTyBinder mb_kind_info) subst bndrs
-       ; traceTc "instantiating tybinders:"
-           (vcat $ zipWith (\bndr arg -> ppr bndr <+> text ":=" <+> ppr arg)
-                           bndrs args)
-       ; return (subst, args) }
+tcInstTyBinders (bndrs, ty)
+  | null bndrs        -- It's fine for bndrs to be empty e.g.
+  = return ([], ty)   -- Check that (Maybe :: forall {k}. k->*),
+                      --       and see the call to instTyBinders in checkExpectedKind
+                      -- A user bug to be reported as such; it is not a compiler crash!
+
+  | otherwise
+  = do { (subst, args) <- mapAccumLM (tcInstTyBinder Nothing) empty_subst bndrs
+       ; ty' <- zonkTcType (substTy subst ty)
+                   -- Why zonk the result? So that tcTyVar can
+                   -- obey (IT6) of Note [The tcType invariant] in TcHsType
+                   -- ToDo: SLPJ: I don't think this is needed
+       ; return (args, ty') }
+  where
+     empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
 
 -- | Used only in *types*
 tcInstTyBinder :: Maybe (VarEnv Kind)
index 73f39ed..f361192 100644 (file)
@@ -208,7 +208,7 @@ check_inst sig_inst = do
            (tvs, theta, pred) }}
         origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst
     (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
-    (cts, tclvl) <- pushTcLevelM $ do
+    (tclvl,cts) <- pushTcLevelM $ do
        wanted <- newWanted origin
                            (Just TypeLevel)
                            (substTy skol_subst pred)
index 11a0e20..abdce58 100644 (file)
@@ -1451,7 +1451,6 @@ tcExtendTyVarEnvForRhs (Just sig) thing_inside
 tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
 tcExtendTyVarEnvFromSig sig_inst thing_inside
   | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
-     -- Note [Use tcExtendTyVar not scopeTyVars in tcRhs]
   = tcExtendNameTyVarEnv wcs $
     tcExtendNameTyVarEnv skol_prs $
     thing_inside
@@ -1591,29 +1590,6 @@ Example for (E2), we generate
 The beta is untoucable, but floats out of the constraint and can
 be solved absolutely fine.
 
-Note [Use tcExtendTyVar not scopeTyVars in tcRhs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Normally, any place that corresponds to Λ or ∀ in Core should be flagged
-with a call to scopeTyVars, which arranges for an implication constraint
-to be made, bumps the TcLevel, and (crucially) prevents a unification
-variable created outside the scope of a local skolem to unify with that
-skolem.
-
-We do not need to do this here, however.
-
-- Note that this happens only in the case of a partial signature.
-  Complete signatures go via tcPolyCheck, not tcPolyInfer.
-
-- The TcLevel is incremented in tcPolyInfer, right outside the call
-  to tcMonoBinds. We thus don't have to worry about outer metatvs unifying
-  with local skolems.
-
-- The other potential concern is that we need SkolemInfo associated with
-  the skolems. This, too, is OK, though: the constraints pass through
-  simplifyInfer (which doesn't report errors), at the end of which
-  the skolems will get quantified and put into an implication constraint.
-  Thus, by the time any errors are reported, the SkolemInfo will be
-  in place.
 
 ************************************************************************
 *                                                                      *
index fe29c3d..f085e07 100644 (file)
@@ -198,9 +198,6 @@ tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 
         ; let tc_item = tcDefMeth clas clas_tyvars this_dict
                                   default_binds sig_fn prag_fn
-                   -- tcExtendTyVarEnv here (instead of scopeTyVars) is OK:
-                   -- the tcDefMeth calls checkConstraints to bump the TcLevel
-                   -- and make the implication constraint
         ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
                       mapM tc_item op_items
 
@@ -517,7 +514,7 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
              tvs'     = scopedSort tv'
              cvs'     = scopedSort cv'
        ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'
-       ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' cvs'
+       ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs'
                                      fam_tc pat_tys' rhs'
            -- NB: no validity check. We check validity of default instances
            -- in the class definition. Because type instance arguments cannot
index 4ee0f23..e2a314c 100644 (file)
@@ -617,7 +617,7 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode))
        ; traceTc "Deriving strategy (standalone deriving)" $
            vcat [ppr mb_deriv_strat, ppr deriv_ty]
        ; (mb_deriv_strat', tvs', (deriv_ctxt', cls, inst_tys'))
-           <- tcDerivStrategy ctxt mb_deriv_strat $ do
+           <- tcDerivStrategy mb_deriv_strat $ do
                 (tvs, deriv_ctxt, cls, inst_tys)
                   <- tcStandaloneDerivInstType ctxt deriv_ty
                 pure (tvs, (deriv_ctxt, cls, inst_tys))
@@ -718,19 +718,19 @@ tcStandaloneDerivInstType ctxt
   | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body
   , L _ [wc_pred] <- theta
   , L _ (HsWildCardTy (AnonWildCard (L wc_span _))) <- ignoreParens wc_pred
-  = do (deriv_tvs, _deriv_theta, deriv_cls, deriv_inst_tys)
-         <- tcHsClsInstType ctxt $
-            HsIB { hsib_ext = vars
-                 , hsib_body
-                     = L (getLoc deriv_ty_body) $
-                       HsForAllTy { hst_bndrs = tvs
-                                  , hst_xforall = noExt
-                                  , hst_body  = rho }}
-       pure (deriv_tvs, InferContext (Just wc_span), deriv_cls, deriv_inst_tys)
+  = do dfun_ty <- tcHsClsInstType ctxt $
+                  HsIB { hsib_ext = vars
+                       , hsib_body
+                           = L (getLoc deriv_ty_body) $
+                             HsForAllTy { hst_bndrs = tvs
+                                        , hst_xforall = noExt
+                                        , hst_body  = rho }}
+       let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
+       pure (tvs, InferContext (Just wc_span), cls, inst_tys)
   | otherwise
-  = do (deriv_tvs, deriv_theta, deriv_cls, deriv_inst_tys)
-         <- tcHsClsInstType ctxt deriv_ty
-       pure (deriv_tvs, SupplyContext deriv_theta, deriv_cls, deriv_inst_tys)
+  = do dfun_ty <- tcHsClsInstType ctxt deriv_ty
+       let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
+       pure (tvs, SupplyContext theta, cls, inst_tys)
 
 tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs _))
   = panic "tcStandaloneDerivInstType"
@@ -746,7 +746,8 @@ warnUselessTypeable
 
 ------------------------------------------------------------------
 deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
-                                             --   Can be a data instance, hence [Type] args
+                    -- Can be a data instance, hence [Type] args
+                    -- and in that case the TyCon is the /family/ tycon
              -> Maybe (DerivStrategy GhcRn)  -- The optional deriving strategy
              -> LHsSigType GhcRn             -- The deriving predicate
              -> TcM (Maybe EarlyDerivSpec)
@@ -759,9 +760,6 @@ deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred
   = setSrcSpan (getLoc (hsSigType deriv_pred)) $
     -- Use loc of the 'deriving' item
     do  { (mb_deriv_strat', deriv_tvs, (cls, cls_tys, cls_arg_kinds))
-                   -- Why not scopeTyVars? Because these are *TyVar*s, not TcTyVars.
-                   -- Their kinds are fully settled. No need to worry about skolem
-                   -- escape.
                 <- tcExtendTyVarEnv tvs $
                 -- Deriving preds may (now) mention
                 -- the type variables for the type constructor, hence tcExtendTyVarenv
@@ -771,7 +769,7 @@ deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred
                 -- Typeable is special, because Typeable :: forall k. k -> Constraint
                 -- so the argument kind 'k' is not decomposable by splitKindFunTys
                 -- as is the case for all other derivable type classes
-                     tcDerivStrategy TcType.DerivClauseCtxt mb_deriv_strat $
+                     tcDerivStrategy mb_deriv_strat $
                      tcHsDeriv deriv_pred
 
         ; when (cls_arg_kinds `lengthIsNot` 1) $
@@ -786,7 +784,8 @@ deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred
            -- we want to drop type variables from T so that (C d (T a)) is well-kinded
           let (arg_kinds, _)  = splitFunTys cls_arg_kind
               n_args_to_drop  = length arg_kinds
-              n_args_to_keep  = tyConArity tc - n_args_to_drop
+              n_args_to_keep  = length tc_args - n_args_to_drop
+                                -- See Note [tc_args and tycon arity]
               (tc_args_to_keep, args_to_drop)
                               = splitAt n_args_to_keep tc_args
               inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)
@@ -891,7 +890,24 @@ deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred
         ; return $ Just spec } }
 
 
-{-
+{- Note [tc_args and tycon arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might wonder if we could use (tyConArity tc) at this point, rather
+than (length tc_args).  But for data families the two can differ!  The
+tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which
+in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them
+from DataFamInstTyCon:
+
+| DataFamInstTyCon          -- See Note [Data type families]
+      (CoAxiom Unbranched)
+      TyCon   -- The family TyCon
+      [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)
+              -- No shorter in length than the tyConTyVars of the family TyCon
+              -- How could it be longer? See [Arity of data families] in FamInstEnv
+
+Notice that the arg tys might not be the same as the family tycon arity
+(= length tyConTyVars).
+
 Note [Unify kinds in deriving]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider (Trac #8534)
index 3f4192f..b026f1d 100644 (file)
@@ -683,7 +683,7 @@ simplifyDeriv pred tvs thetas
        -- with the skolemized variables.  Start "one level down" because
        -- we are going to wrap the result in an implication with tvs_skols,
        -- in step [DAC RESIDUAL]
-       ; (wanteds, tc_lvl) <- pushTcLevelM $
+       ; (tc_lvl, wanteds) <- pushTcLevelM $
                               mapM mk_wanteds thetas
 
        ; traceTc "simplifyDeriv inputs" $
index 946cb5c..d32272b 100644 (file)
@@ -467,18 +467,10 @@ tcExtendKindEnv extra_env thing_inside
 
 -----------------------
 -- Scoped type and kind variables
--- Before using this function, consider using TcHsType.scopeTyVars, which
--- bumps the TcLevel and thus prevents any of these TyVars from appearing
--- in kinds of tyvars in an outer scope.
--- Indeed, you should always use scopeTyVars unless some other code nearby
--- bumps the TcLevel.
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 tcExtendTyVarEnv tvs thing_inside
   = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside
 
--- Before using this function, consider using TcHsType.scopeTyVars2, which
--- bumps the TcLevel and thus prevents any of these TyVars from appearing
--- in kinds of tyvars in an outer scope.
 tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r
 tcExtendNameTyVarEnv binds thing_inside
   -- this should be used only for explicitly mentioned scoped variables.
@@ -569,7 +561,7 @@ tc_extend_local_env top_lvl extra_env thing_inside
 --
 -- Invariant: the ATcIds are fully zonked. Reasons:
 --      (a) The kinds of the forall'd type variables are defaulted
---          (see Kind.defaultKind, done in zonkQuantifiedTyVar)
+--          (see Kind.defaultKind, done in skolemiseQuantifiedTyVar)
 --      (b) There are no via-Indirect occurrences of the bound variables
 --          in the types, because instantiation does not look through such things
 --      (c) The call to tyCoVarsOfTypes is ok without looking through refs
index 7c33834..cfd364f 100644 (file)
@@ -148,8 +148,9 @@ reportUnsolved wanted
                                 | warn_out_of_scope      = HoleWarn
                                 | otherwise              = HoleDefer
 
-       ; report_unsolved binds_var type_errors expr_holes
-          type_holes out_of_scope_holes wanted
+       ; report_unsolved type_errors expr_holes
+                         type_holes out_of_scope_holes
+                         binds_var wanted
 
        ; ev_binds <- getTcEvBindsMap binds_var
        ; return (evBindMapBinds ev_binds)}
@@ -164,8 +165,8 @@ reportUnsolved wanted
 reportAllUnsolved :: WantedConstraints -> TcM ()
 reportAllUnsolved wanted
   = do { ev_binds <- newNoTcEvBinds
-       ; report_unsolved ev_binds TypeError
-                         HoleError HoleError HoleError wanted }
+       ; report_unsolved TypeError HoleError HoleError HoleError
+                         ev_binds wanted }
 
 -- | Report all unsolved goals as warnings (but without deferring any errors to
 -- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in
@@ -173,26 +174,26 @@ reportAllUnsolved wanted
 warnAllUnsolved :: WantedConstraints -> TcM ()
 warnAllUnsolved wanted
   = do { ev_binds <- newTcEvBinds
-       ; report_unsolved ev_binds (TypeWarn NoReason)
-                         HoleWarn HoleWarn HoleWarn wanted }
+       ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn
+                         ev_binds wanted }
 
 -- | Report unsolved goals as errors or warnings.
-report_unsolved :: EvBindsVar        -- cec_binds
-                -> TypeErrorChoice   -- Deferred type errors
+report_unsolved :: TypeErrorChoice   -- Deferred type errors
                 -> HoleChoice        -- Expression holes
                 -> HoleChoice        -- Type holes
                 -> HoleChoice        -- Out of scope holes
+                -> EvBindsVar        -- cec_binds
                 -> WantedConstraints -> TcM ()
-report_unsolved mb_binds_var type_errors expr_holes
-    type_holes out_of_scope_holes wanted
+report_unsolved type_errors expr_holes
+    type_holes out_of_scope_holes binds_var wanted
   | isEmptyWC wanted
   = return ()
   | otherwise
-  = do { traceTc "reportUnsolved warning/error settings:" $
-           vcat [ text "type errors:" <+> ppr type_errors
-                , text "expr holes:" <+> ppr expr_holes
-                , text "type holes:" <+> ppr type_holes
-                , text "scope holes:" <+> ppr out_of_scope_holes ]
+  = do { traceTc "reportUnsolved {" $
+         vcat [ text "type errors:" <+> ppr type_errors
+              , text "expr holes:" <+> ppr expr_holes
+              , text "type holes:" <+> ppr type_holes
+              , text "scope holes:" <+> ppr out_of_scope_holes ]
        ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
 
        ; wanted <- zonkWC wanted   -- Zonk to reveal all information
@@ -221,10 +222,11 @@ report_unsolved mb_binds_var type_errors expr_holes
                                  -- See Trac #15539 and c.f. setting ic_status
                                  -- in TcSimplify.setImplicationStatus
                             , cec_warn_redundant = warn_redundant
-                            , cec_binds    = mb_binds_var }
+                            , cec_binds    = binds_var }
 
        ; tc_lvl <- getTcLevel
-       ; reportWanteds err_ctxt tc_lvl wanted }
+       ; reportWanteds err_ctxt tc_lvl wanted
+       ; traceTc "reportUnsolved }" empty }
 
 --------------------------------------------
 --      Internal functions
index b194eac..701df5f 100644 (file)
@@ -62,7 +62,8 @@ import SrcLoc
 import TyCon
 import TcEnv
 import TcType
-import TcValidity ( checkValidTyFamEqn )
+import TcValidity ( checkValidCoAxBranch )
+import CoAxiom    ( coAxiomSingleBranch )
 import TysPrim
 import TysWiredIn
 import Type
@@ -1867,11 +1868,10 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
     mk_atf_inst fam_tc = do
         rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc))
                                            rep_lhs_tys
-        let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' rep_cvs'
+        let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs'
                                     fam_tc rep_lhs_tys rep_rhs_ty
         -- Check (c) from Note [GND and associated type families] in TcDeriv
-        checkValidTyFamEqn (Just (cls, cls_tvs, lhs_env)) fam_tc rep_tvs'
-                           rep_cvs' rep_lhs_tys rep_rhs_ty pp_lhs loc
+        checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)
         newFamInst SynFamilyInst axiom
       where
         cls_tvs     = classTyVars cls
@@ -1888,7 +1888,6 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
         (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
         rep_tvs'    = scopedSort rep_tvs
         rep_cvs'    = scopedSort rep_cvs
-        pp_lhs      = ppr (mkTyConApp fam_tc rep_lhs_tys)
 
     -- Same as inst_tys, but with the last argument type replaced by the
     -- representation type.
index 6372c66..abc7d59 100644 (file)
@@ -436,7 +436,7 @@ tc_mkRepFamInsts gk tycon inst_tys =
            (tv', cv') = partition isTyVar tcv'
            tvs'       = scopedSort tv'
            cvs'       = scopedSort cv'
-           axiom      = mkSingleCoAxiom Nominal rep_name tvs' cvs'
+           axiom      = mkSingleCoAxiom Nominal rep_name tvs' [] cvs'
                                         fam_tc inst_tys repTy'
 
      ; newFamInst SynFamilyInst axiom  }
index 450a7d9..16cee70 100644 (file)
@@ -40,7 +40,8 @@ module TcHsSyn (
         zonkTyVarOcc,
         zonkCoToCo,
         zonkEvBinds, zonkTcEvBinds,
-        zonkTcMethInfoToMethInfoX
+        zonkTcMethInfoToMethInfoX,
+        lookupTyVarOcc
   ) where
 
 #include "HsVersions.h"
@@ -1770,9 +1771,9 @@ zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi
 
     zonk_meta mtv_env ref Flexi
       = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv)
-           ; let ty = commitFlexi flexi tv kind
+           ; ty <- commitFlexi flexi tv kind
            ; writeMetaTyVarRef tv ref ty  -- Belt and braces
-           ; finish_meta mtv_env (commitFlexi flexi tv kind) }
+           ; finish_meta mtv_env ty }
 
     zonk_meta mtv_env _ (Indirect ty)
       = do { zty <- zonkTcTypeToTypeX env ty
@@ -1783,17 +1784,27 @@ zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi
            ; writeTcRef mtv_env_ref mtv_env'
            ; return ty }
 
-commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> Type
+lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar
+lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv
+  = lookupVarEnv tv_env tv
+
+commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type
+-- Only monadic so we can do tc-tracing
 commitFlexi flexi tv zonked_kind
   = case flexi of
-      SkolemiseFlexi  -> mkTyVarTy (mkTyVar name zonked_kind)
-
-      DefaultFlexi    | isRuntimeRepTy zonked_kind
-                      -> liftedRepTy
-                      | otherwise
-                      -> anyTypeOfKind zonked_kind
-
-      RuntimeUnkFlexi -> mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)
+      SkolemiseFlexi  -> return (mkTyVarTy (mkTyVar name zonked_kind))
+
+      DefaultFlexi
+        | isRuntimeRepTy zonked_kind
+        -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)
+              ; return liftedRepTy }
+        | otherwise
+        -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv)
+              ; return (anyTypeOfKind zonked_kind) }
+
+      RuntimeUnkFlexi
+        -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv)
+              ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) }
                         -- This is where RuntimeUnks are born:
                         -- otherwise-unconstrained unification variables are
                         -- turned into RuntimeUnks as they leave the
index 1181f38..4a4d49b 100644 (file)
@@ -20,16 +20,18 @@ module TcHsType (
         tcHsDeriv, tcDerivStrategy,
         tcHsTypeApp,
         UserTypeCtxt(..),
-        tcImplicitTKBndrs, tcImplicitQTKBndrs,
-        tcExplicitTKBndrs,
-        kcExplicitTKBndrs, kcImplicitTKBndrs,
+        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,
+            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,
+        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,
+            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,
+        ContextKind(..),
 
                 -- Type checking type and class decls
-        kcLookupTcTyCon, kcTyClTyVars, tcTyClTyVars,
-        tcDataKindSig,
+        kcLookupTcTyCon, bindTyClTyVars,
+        etaExpandAlgTyCon, tcbVisibilities,
 
           -- tyvars
-        scopeTyVars, scopeTyVars2,
+        zonkAndScopedSort,
 
         -- Kind-checking types
         -- No kind generalisation, no checkValidType
@@ -44,7 +46,7 @@ module TcHsType (
 
         typeLevelMode, kindLevelMode,
 
-        kindGeneralize, checkExpectedKindX, instantiateTyUntilN,
+        kindGeneralize, checkExpectedKindX,
         reportFloatingKvs,
 
         -- Sort-checking kinds
@@ -77,7 +79,7 @@ import TcHsSyn
 import TcErrors ( reportAllUnsolved )
 import TcType
 import Inst   ( tcInstTyBinders, tcInstTyBinder )
-import TyCoRep( TyCoBinder(..), TyBinder )  -- Used in tcDataKindSig
+import TyCoRep( TyCoBinder(..), TyBinder )  -- Used in etaExpandAlgTyCon
 import Type
 import Coercion
 import RdrName( lookupLocalRdrOcc )
@@ -96,6 +98,7 @@ import SrcLoc
 import Constants ( mAX_CTUPLE_SIZE )
 import ErrUtils( MsgDoc )
 import Unique
+import UniqSet
 import Util
 import UniqSupply
 import Outputable
@@ -104,7 +107,7 @@ import PrelNames hiding ( wildCardName )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Maybes
-import Data.List ( find, mapAccumR )
+import Data.List ( find )
 import Control.Monad
 
 {-
@@ -182,20 +185,24 @@ tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
 -- already checked this, so we can simply ignore it.
 tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)
 
-kcHsSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()
-kcHsSigType skol_info names (HsIB { hsib_body = hs_ty
+kcHsSigType :: [Located Name] -> LHsSigType GhcRn -> TcM ()
+kcHsSigType names (HsIB { hsib_body = hs_ty
                                   , hsib_ext = sig_vars })
   = addSigCtxt (funsSigCtxt names) hs_ty $
     discardResult $
-    tcImplicitTKBndrs skol_info sig_vars $
+    bindImplicitTKBndrs_Skol sig_vars $
     tc_lhs_type typeLevelMode hs_ty liftedTypeKind
-kcHsSigType  _ _ (XHsImplicitBndrs _) = panic "kcHsSigType"
+
+kcHsSigType _ (XHsImplicitBndrs _) = panic "kcHsSigType"
 
 tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type
 -- Does not do validity checking
 tcClassSigType skol_info names sig_ty
   = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $
-    tc_hs_sig_type_and_gen skol_info sig_ty liftedTypeKind
+    tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind)
+       -- Do not zonk-to-Type, nor perform a validity check
+       -- We are in a knot with the class and associated types
+       -- Zonking and validity checking is done by tcClassDecl
 
 tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
 -- Does validity checking
@@ -203,15 +210,10 @@ tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
 tcHsSigType ctxt sig_ty
   = addSigCtxt ctxt (hsSigType sig_ty) $
     do { traceTc "tcHsSigType {" (ppr sig_ty)
-       ; kind <- case expectedKindInCtxt ctxt of
-                    AnythingKind -> newMetaKindVar
-                    TheKind k    -> return k
-                    OpenKind     -> newOpenTypeKind
-              -- The kind is checked by checkValidType, and isn't necessarily
-              -- of kind * in a Template Haskell quote eg [t| Maybe |]
 
           -- Generalise here: see Note [Kind generalisation]
-       ; ty <- tc_hs_sig_type_and_gen skol_info sig_ty kind
+       ; ty <- tc_hs_sig_type skol_info sig_ty
+                                      (expectedKindInCtxt ctxt)
        ; ty <- zonkTcType ty
 
        ; checkValidType ctxt ty
@@ -220,27 +222,59 @@ tcHsSigType ctxt sig_ty
   where
     skol_info = SigTypeSkol ctxt
 
-tc_hs_sig_type_and_gen :: SkolemInfo -> LHsSigType GhcRn -> Kind -> TcM Type
+tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn
+               -> ContextKind -> TcM Type
 -- Kind-checks/desugars an 'LHsSigType',
 --   solve equalities,
 --   and then kind-generalizes.
 -- This will never emit constraints, as it uses solveEqualities interally.
 -- No validity checking or zonking
-tc_hs_sig_type_and_gen skol_info (HsIB { hsib_ext = sig_vars
-                                       , hsib_body = hs_ty }) kind
-  = do { ((tkvs, ty), wanted) <- captureConstraints $
-                                 tcImplicitTKBndrs skol_info sig_vars $
-                                 tc_lhs_type typeLevelMode hs_ty kind
-         -- Any remaining variables (unsolved in the solveLocalEqualities
-         -- in the tcImplicitTKBndrs) should be in the global tyvars,
-         -- and therefore won't be quantified over
-
-       ; let ty1 = mkSpecForAllTys tkvs ty
+tc_hs_sig_type skol_info hs_sig_type ctxt_kind
+  | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type
+  = do { (tc_lvl, (wanted, (spec_tkvs, ty)))
+              <- pushTcLevelM                           $
+                 solveLocalEqualitiesX "tc_hs_sig_type" $
+                 bindImplicitTKBndrs_Skol sig_vars      $
+                 do { kind <- newExpectedKind ctxt_kind
+
+                    ; tc_lhs_type typeLevelMode hs_ty kind }
+       -- Any remaining variables (unsolved in the solveLocalEqualities)
+       -- should be in the global tyvars, and therefore won't be quantified
+
+       ; spec_tkvs <- zonkAndScopedSort spec_tkvs
+       ; let ty1 = mkSpecForAllTys spec_tkvs ty
        ; kvs <- kindGeneralizeLocal wanted ty1
-       ; emitConstraints wanted -- we still need to solve these
+       ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs)
+                                  tc_lvl wanted
+
        ; return (mkInvForAllTys kvs ty1) }
 
-tc_hs_sig_type_and_gen _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type_and_gen"
+tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type_and_gen"
+
+tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type
+-- tcTopLHsType is used for kind-checking top-level HsType where
+--   we want to fully solve /all/ equalities, and report errors
+-- Does zonking, but not validity checking because it's used
+--   for things (like deriving and instances) that aren't
+--   ordinary types
+tcTopLHsType hs_sig_type ctxt_kind
+  | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type
+  = do { traceTc "tcTopLHsType {" (ppr hs_ty)
+       ; (spec_tkvs, ty)
+              <- pushTcLevelM_                     $
+                 solveEqualities                   $
+                 bindImplicitTKBndrs_Skol sig_vars $
+                 do { kind <- newExpectedKind ctxt_kind
+                    ; tc_lhs_type typeLevelMode hs_ty kind }
+
+       ; spec_tkvs <- zonkAndScopedSort spec_tkvs
+       ; let ty1 = mkSpecForAllTys spec_tkvs ty
+       ; kvs <- kindGeneralize ty1
+       ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1)
+       ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty])
+       ; return final_ty}
+
+tcTopLHsType (XHsImplicitBndrs _) _ = panic "tcTopLHsType"
 
 -----------------
 tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind]))
@@ -251,18 +285,13 @@ tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind]))
 --    returns ([k], C, [k, Int], [k->k])
 -- Return values are fully zonked
 tcHsDeriv hs_ty
-  = do { cls_kind <- newMetaKindVar
-                    -- always safe to kind-generalize, because there
-                    -- can be no covars in an outer scope
-       ; ty <- checkNoErrs $
-                 -- avoid redundant error report with "illegal deriving", below
-               tc_hs_sig_type_and_gen (SigTypeSkol DerivClauseCtxt) hs_ty cls_kind
-       ; cls_kind <- zonkTcTypeToType cls_kind
-       ; ty <- zonkTcTypeToType ty
-       ; let (tvs, pred) = splitForAllTys ty
-       ; let (args, _) = splitFunTys cls_kind
+  = do { ty <- checkNoErrs $  -- Avoid redundant error report
+                              -- with "illegal deriving", below
+               tcTopLHsType hs_ty AnyKind
+       ; let (tvs, pred)    = splitForAllTys ty
+             (kind_args, _) = splitFunTys (typeKind pred)
        ; case getClassPredTys_maybe pred of
-           Just (cls, tys) -> return (tvs, (cls, tys, args))
+           Just (cls, tys) -> return (tvs, (cls, tys, kind_args))
            Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }
 
 -- | Typecheck something within the context of a deriving strategy.
@@ -278,15 +307,14 @@ tcHsDeriv hs_ty
 -- the type variable @a@.
 tcDerivStrategy
   :: forall a.
-     UserTypeCtxt
-  -> Maybe (DerivStrategy GhcRn) -- ^ The deriving strategy
+     Maybe (DerivStrategy GhcRn) -- ^ The deriving strategy
   -> TcM ([TyVar], a) -- ^ The thing to typecheck within the context of the
                       -- deriving strategy, which might quantify some type
                       -- variables of its own.
   -> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)
      -- ^ The typechecked deriving strategy, all quantified tyvars, and
      -- the payload of the typechecked thing.
-tcDerivStrategy user_ctxt mds thing_inside
+tcDerivStrategy mds thing_inside
   = case mds of
       Nothing -> boring_case Nothing
       Just ds -> do (ds', tvs, thing) <- tc_deriv_strategy ds
@@ -298,10 +326,8 @@ tcDerivStrategy user_ctxt mds thing_inside
     tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy
     tc_deriv_strategy NewtypeStrategy  = boring_case NewtypeStrategy
     tc_deriv_strategy (ViaStrategy ty) = do
-      cls_kind <- newMetaKindVar
       ty' <- checkNoErrs $
-             tc_hs_sig_type_and_gen (SigTypeSkol user_ctxt) ty cls_kind
-      ty' <- zonkTcTypeToType ty'
+             tcTopLHsType ty AnyKind
       let (via_tvs, via_pred) = splitForAllTys ty'
       tcExtendTyVarEnv via_tvs $ do
         (thing_tvs, thing) <- thing_inside
@@ -314,20 +340,18 @@ tcDerivStrategy user_ctxt mds thing_inside
 
 tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt
                 -> LHsSigType GhcRn
-                -> TcM ([TyVar], ThetaType, Class, [Type])
+                -> TcM Type
 -- Like tcHsSigType, but for a class instance declaration
 tcHsClsInstType user_ctxt hs_inst_ty
   = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $
-    {- We want to fail here if the tc_hs_sig_type_and_gen emits constraints.
-       First off, we know we'll never solve the constraints, as classes are
-       always at top level, and their constraints do not inform the kind checking
-       of method types. So failing isn't wrong. Yet, the reason we do it is
-       to avoid the validity checker from seeing unsolved coercion holes in
-       types. Much better just to report the kind error directly. -}
-    do { inst_ty <- failIfEmitsConstraints $
-                    tc_hs_sig_type_and_gen (SigTypeSkol user_ctxt) hs_inst_ty constraintKind
-       ; inst_ty <- zonkTcTypeToType inst_ty
-       ; checkValidInstance user_ctxt hs_inst_ty inst_ty }
+    do { -- Fail eagerly if tcTopLHsType fails.  We are at top level so
+         -- these constraints will never be solved later. And failing
+         -- eagerly avoids follow-on errors when checkValidInstance
+         -- sees an unsolved coercion hole
+         inst_ty <- checkNoErrs $
+                    tcTopLHsType hs_inst_ty (TheKind constraintKind)
+       ; checkValidInstance user_ctxt hs_inst_ty inst_ty
+       ; return inst_ty }
 
 ----------------------------------------------
 -- | Type-check a visible type application
@@ -335,7 +359,7 @@ tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type
 -- See Note [Recipe for checking a signature] in TcHsType
 tcHsTypeApp wc_ty kind
   | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty
-  = do { ty <- solveLocalEqualities $
+  = do { ty <- solveLocalEqualities "tcHsTypeApp" $
                -- We are looking at a user-written type, very like a
                -- signature so we want to solve its equalities right now
                tcWildCardBinders sig_wcs $ \ _ ->
@@ -640,11 +664,18 @@ tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind
 
 --------- Foralls
 tc_hs_type mode forall@(HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind
-  = do { (tvs', ty') <- tcExplicitTKBndrs (ForAllSkol (ppr forall)) hs_tvs $
-                        tc_lhs_type mode ty exp_kind
+  = do { (tclvl, wanted, (tvs', ty'))
+            <- pushLevelAndCaptureConstraints $
+               bindExplicitTKBndrs_Skol hs_tvs $
+               tc_lhs_type mode ty exp_kind
     -- Do not kind-generalise here!  See Note [Kind generalisation]
     -- Why exp_kind?  See Note [Body kind of HsForAllTy]
-       ; let bndrs      = mkTyVarBinders Specified tvs'
+       ; let bndrs       = mkTyVarBinders Specified tvs'
+             skol_info   = ForAllSkol (ppr forall)
+             m_telescope = Just (sep (map ppr hs_tvs))
+
+       ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted
+
        ; return (mkForAllTys bndrs ty') }
 
 tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind
@@ -857,56 +888,53 @@ bigConstraintTuple arity
 -- | Apply a type of a given kind to a list of arguments. This instantiates
 -- invisible parameters as necessary. Always consumes all the arguments,
 -- using matchExpectedFunKind as necessary.
--- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.
+-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.-
 -- These kinds should be used to instantiate invisible kind variables;
 -- they come from an enclosing class for an associated type/data family.
 tcInferApps :: TcTyMode
-            -> Maybe (VarEnv Kind)  -- ^ Possibly, kind info (see above)
             -> LHsType GhcRn        -- ^ Function (for printing only)
             -> TcType               -- ^ Function
             -> TcKind               -- ^ Function kind (zonked)
             -> [LHsType GhcRn]      -- ^ Args
-            -> TcM (TcType, [TcType], TcKind) -- ^ (f args, args, result kind)
+            -> TcM (TcType, TcKind) -- ^ (f args, args, result kind)
 -- Precondition: typeKind fun_ty = fun_ki
 --    Reason: we will return a type application like (fun_ty arg1 ... argn),
 --            and that type must be well-kinded
 --            See Note [The tcType invariant]
 -- Postcondition: Result kind is zonked.
-tcInferApps mode mb_kind_info orig_hs_ty fun_ty fun_ki orig_hs_args
+tcInferApps mode orig_hs_ty fun_ty fun_ki orig_hs_args
   = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args $$ ppr fun_ki)
-       ; (f_args, args, res_k) <- go 1 [] empty_subst fun_ty orig_ki_binders orig_inner_ki orig_hs_args
+       ; (f_args, res_k) <- go 1 empty_subst fun_ty orig_ki_binders orig_inner_ki orig_hs_args
        ; traceTc "tcInferApps }" empty
-       ; res_k <- zonkTcType res_k  -- nec'y to uphold (IT4) of Note [The tcType invariant]
-       ; return (f_args, args, res_k) }
+       ; res_k <- zonkTcType res_k  -- Uphold (IT4) of Note [The tcType invariant]
+       ; return (f_args, res_k) }
   where
     empty_subst                      = mkEmptyTCvSubst $ mkInScopeSet $
                                        tyCoVarsOfType fun_ki
     (orig_ki_binders, orig_inner_ki) = tcSplitPiTys fun_ki
 
     go :: Int             -- the # of the next argument
-       -> [TcType]        -- already type-checked args, in reverse order
        -> TCvSubst        -- instantiating substitution
        -> TcType          -- function applied to some args
        -> [TyBinder]      -- binders in function kind (both vis. and invis.)
        -> TcKind          -- function kind body (not a Pi-type)
        -> [LHsType GhcRn] -- un-type-checked args
-       -> TcM (TcType, [TcType], TcKind)  -- same as overall return type
+       -> TcM (TcType, TcKind)  -- same as overall return type
 
       -- no user-written args left. We're done!
-    go _ acc_args subst fun ki_binders inner_ki []
+    go _ subst fun ki_binders inner_ki []
       = return ( fun
-               , reverse acc_args
                , nakedSubstTy subst $ mkPiTys ki_binders inner_ki)
                  -- nakedSubstTy: see Note [The well-kinded type invariant]
 
       -- The function's kind has a binder. Is it visible or invisible?
-    go n acc_args subst fun (ki_binder:ki_binders) inner_ki
+    go n subst fun (ki_binder:ki_binders) inner_ki
        all_args@(arg:args)
       | isInvisibleBinder ki_binder
         -- It's invisible. Instantiate.
       = do { traceTc "tcInferApps (invis)" (ppr ki_binder $$ ppr subst)
-           ; (subst', arg') <- tcInstTyBinder mb_kind_info subst ki_binder
-           ; go n (arg' : acc_args) subst' (mkNakedAppTy fun arg')
+           ; (subst', arg') <- tcInstTyBinder Nothing subst ki_binder
+           ; go n subst' (mkNakedAppTy fun arg')
                 ki_binders inner_ki all_args }
 
       | otherwise
@@ -920,15 +948,15 @@ tcInferApps mode mb_kind_info orig_hs_ty fun_ty fun_ki orig_hs_args
                      tc_lhs_type mode arg exp_kind
            ; traceTc "tcInferApps (vis 1)" (ppr exp_kind)
            ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg'
-           ; go (n+1) (arg' : acc_args) subst'
+           ; go (n+1) subst'
                 (mkNakedAppTy fun arg') -- See Note [The well-kinded type invariant]
                 ki_binders inner_ki args }
 
        -- We've run out of known binders in the functions's kind.
-    go n acc_args subst fun [] inner_ki all_args
+    go n subst fun [] inner_ki all_args
       | not (null new_ki_binders)
          -- But, after substituting, we have more binders.
-      = go n acc_args zapped_subst fun new_ki_binders new_inner_ki all_args
+      = go n zapped_subst fun new_ki_binders new_inner_ki all_args
 
       | otherwise
          -- Even after substituting, still no binders. Use matchExpectedFunKind
@@ -936,7 +964,7 @@ tcInferApps mode mb_kind_info orig_hs_ty fun_ty fun_ki orig_hs_args
            ; (co, arg_k, res_k) <- matchExpectedFunKind hs_ty substed_inner_ki
            ; let new_in_scope = tyCoVarsOfTypes [arg_k, res_k]
                  subst'       = zapped_subst `extendTCvInScopeSet` new_in_scope
-           ; go n acc_args subst'
+           ; go n subst'
                 (fun `mkNakedCastTy` co)  -- See Note [The well-kinded type invariant]
                 [mkAnonBinder arg_k]
                 res_k all_args }
@@ -959,7 +987,7 @@ tcTyApps :: TcTyMode
          -> TcM (TcType, TcKind) -- ^ (f args, result kind)   result kind is zonked
 -- Precondition: see precondition for tcInferApps
 tcTyApps mode orig_hs_ty fun_ty fun_ki args
-  = do { (ty', _args, ki') <- tcInferApps mode Nothing orig_hs_ty fun_ty fun_ki args
+  = do { (ty', ki') <- tcInferApps mode orig_hs_ty fun_ty fun_ki args
        ; return (ty' `mkNakedCastTy` mkNomReflCo ki', ki') }
           -- The mkNakedCastTy is for (IT3) of Note [The tcType invariant]
 
@@ -972,29 +1000,28 @@ checkExpectedKind :: HasDebugCallStack
                   -> TcKind         -- the known kind of that type
                   -> TcKind         -- the expected kind
                   -> TcM TcType
-checkExpectedKind hs_ty ty act exp
-  = fstOf3 <$> checkExpectedKindX Nothing (ppr hs_ty) ty act exp
+checkExpectedKind hs_ty ty act exp = checkExpectedKindX (ppr hs_ty) ty act exp
 
 checkExpectedKindX :: HasDebugCallStack
-                   => Maybe (VarEnv Kind)  -- Possibly, instantiations for kind vars
-                   -> SDoc                 -- HsType whose kind we're checking
+                   => SDoc                 -- HsType whose kind we're checking
                    -> TcType               -- the type whose kind we're checking
                    -> TcKind               -- the known kind of that type, k
                    -> TcKind               -- the expected kind, exp_kind
-                   -> TcM (TcType, [TcType], TcCoercionN)
+                   -> TcM TcType
     -- (the new args, the coercion)
 -- Instantiate a kind (if necessary) and then call unifyType
 --      (checkExpectedKind ty act_kind exp_kind)
 -- checks that the actual kind act_kind is compatible
 --      with the expected kind exp_kind
-checkExpectedKindX mb_kind_env pp_hs_ty ty act_kind exp_kind
+checkExpectedKindX pp_hs_ty ty act_kind exp_kind
  = do { -- We need to make sure that both kinds have the same number of implicit
         -- foralls out front. If the actual kind has more, instantiate accordingly.
         -- Otherwise, just pass the type & kind through: the errors are caught
         -- in unifyType.
-        let (exp_bndrs, _) = splitPiTysInvisible exp_kind
-            n_exp          = length exp_bndrs
-      ; (new_args, act_kind') <- instantiateTyUntilN mb_kind_env n_exp act_kind
+        let n_exp_invis_bndrs = invisibleTyBndrCount exp_kind
+            n_act_invis_bndrs = invisibleTyBndrCount act_kind
+            n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs
+      ; (new_args, act_kind') <- tcInstTyBinders (splitPiTysInvisibleN n_to_inst act_kind)
 
       ; let origin = TypeEqOrigin { uo_actual   = act_kind'
                                   , uo_expected = exp_kind
@@ -1009,54 +1036,14 @@ checkExpectedKindX mb_kind_env pp_hs_ty ty act_kind exp_kind
              , text "exp_kind:" <+> ppr exp_kind ]
 
       ; if act_kind' `tcEqType` exp_kind
-        then return (ty', new_args, mkTcNomReflCo exp_kind)  -- This is very common
+        then return ty'   -- This is very common
         else do { co_k <- uType KindLevel origin act_kind' exp_kind
                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind
                                                     , ppr exp_kind
                                                     , ppr co_k ])
                 ; let result_ty = ty' `mkNakedCastTy` co_k
                       -- See Note [The tcType invariant]
-                ; return (result_ty, new_args, co_k) } }
-
--- | Instantiate @n@ invisible arguments to a type. If @n <= 0@, no instantiation
--- occurs. If @n@ is too big, then all available invisible arguments are instantiated.
--- (In other words, this function is very forgiving about bad values of @n@.)
--- Why zonk the result? So that tcTyVar can obey (IT6) of Note [The tcType invariant]
-instantiateTyN :: Maybe (VarEnv Kind)              -- ^ Predetermined instantiations
-                                                   -- (for assoc. type patterns)
-               -> Int                              -- ^ @n@
-               -> [TyBinder] -> TcKind             -- ^ its kind (zonked)
-               -> TcM ([TcType], TcKind)   -- ^ The inst'ed type, new args, kind (zonked)
-instantiateTyN mb_kind_env n bndrs inner_ki
-  | n <= 0
-  = return ([], ki)
-
-  | otherwise
-  = do { (subst, inst_args) <- tcInstTyBinders empty_subst mb_kind_env inst_bndrs
-       ; let rebuilt_ki = mkPiTys leftover_bndrs inner_ki
-       ; ki' <- zonkTcType (substTy subst rebuilt_ki)
-       ; traceTc "instantiateTyN" (vcat [ ppr ki
-                                        , ppr n
-                                        , ppr subst
-                                        , ppr rebuilt_ki
-                                        , ppr ki' ])
-       ; return (inst_args, ki') }
-  where
-     -- NB: splitAt is forgiving with invalid numbers
-     (inst_bndrs, leftover_bndrs) = splitAt n bndrs
-     ki          = mkPiTys bndrs inner_ki
-     empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ki))
-
--- | Instantiate a type to have at most @n@ invisible arguments.
-instantiateTyUntilN :: Maybe (VarEnv Kind)   -- ^ Possibly, instantiations for vars
-                    -> Int         -- ^ @n@
-                    -> TcKind      -- ^ its kind
-                    -> TcM ([TcType], TcKind)   -- ^ The new args, final kind
-instantiateTyUntilN mb_kind_env n ki
-  = let (bndrs, inner_ki) = splitPiTysInvisible ki
-        num_to_inst       = length bndrs - n
-    in
-    instantiateTyN mb_kind_env num_to_inst bndrs inner_ki
+                ; return result_ty } }
 
 ---------------------------
 tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]
@@ -1144,11 +1131,13 @@ tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon
               -- the mkNakedCastTy ensures (IT5) of Note [The tcType invariant]
 
       | otherwise
-      = do { tc_kind <- zonkTcType (tyConKind tc)
-           ; let (tc_kind_bndrs, tc_inner_ki) = splitPiTysInvisible tc_kind
-           ; (tc_args, kind) <- instantiateTyN Nothing (length (tyConBinders tc))
-                                               tc_kind_bndrs tc_inner_ki
-           ; let is_saturated = tc_args `lengthAtLeast` tyConArity tc
+      = do { let tc_arity = tyConArity tc
+           ; tc_kind <- zonkTcType (tyConKind tc)
+           ; (tc_args, kind) <- tcInstTyBinders (splitPiTysInvisibleN tc_arity tc_kind)
+                 -- Instantiate enough invisible arguments
+                 -- to saturate the family TyCon
+
+           ; let is_saturated = tc_args `lengthAtLeast` tc_arity
                  tc_ty
                    | is_saturated = mkTyConApp tc tc_args `mkNakedCastTy` mkNomReflCo kind
                       -- mkNakedCastTy is for (IT5) of Note [The tcType invariant]
@@ -1371,51 +1360,6 @@ Sidenote: It's quite possible that later, we'll consider (t -> s)
 as a degenerate case of some (pi (x :: t) -> s) and then this will
 all get more permissive.
 
-Note [Kind generalisation and TyVarTvs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data T (a :: k1) x = MkT (S a ())
-  data S (b :: k2) y = MkS (T b ())
-
-While we are doing kind inference for the mutually-recursive S,T,
-we will end up unifying k1 and k2 together. So they can't be skolems.
-We therefore make them TyVarTvs, which can unify with type variables,
-but not with general types.  All this is very similar at the level
-of terms: see Note [Quantified variables in partial type signatures]
-in TcBinds.
-
-There are some wrinkles
-
-* We always want to kind-generalise over TyVarTvs, and /not/ default
-  them to Type.  Another way to say this is: a TyVarTv should /never/
-  stand for a type, even via defaulting. Hence the check in
-  TcSimplify.defaultTyVarTcS, and TcMType.defaultTyVar.  Here's
-  another example (Trac #14555):
-     data Exp :: [TYPE rep] -> TYPE rep -> Type where
-        Lam :: Exp (a:xs) b -> Exp xs (a -> b)
-  We want to kind-generalise over the 'rep' variable.
-  Trac #14563 is another example.
-
-* Consider Trac #11203
-    data SameKind :: k -> k -> *
-    data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)
-  Here we will unify k1 with k2, but this time doing so is an error,
-  because k1 and k2 are bound in the same declaration.
-
-  We sort this out using findDupTyVarTvs, in TcHsType.tcTyClTyVars; very much
-  as we do with partial type signatures in mk_psig_qtvs in
-  TcBinds.chooseInferredQuantifiers
-
-* Even the Required arguments should be made into TyVarTvs, not skolems.
-  Consider
-
-    data T k (a :: k)
-
-  Here, k is a Required, dependent variable. For uniformity, it is helpful
-  to have k be a TyVarTv, in parallel with other dependent variables.
-  (This is key in the call to quantifyTyVars in kcTyClGroup, where quantifyTyVars
-  expects not to see unknown skolems.)
-
 Note [Keeping scoped variables in order: Explicit]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When the user writes `forall a b c. blah`, we bring a, b, and c into
@@ -1508,7 +1452,6 @@ To avoid the double-zonk, we do two things:
  2. When we are generalizing:
     kindGeneralize does not require a zonked type -- it zonks as it
     gathers free variables. So this way effectively sidesteps step 3.
-
 -}
 
 tcWildCardBinders :: [Name]
@@ -1520,6 +1463,44 @@ tcWildCardBinders wc_names thing_inside
        ; tcExtendNameTyVarEnv wc_prs $
          thing_inside wc_prs }
 
+newWildTyVar :: Name -> TcM TcTyVar
+-- ^ New unification variable for a wildcard
+newWildTyVar _name
+  = do { kind <- newMetaKindVar
+       ; uniq <- newUnique
+       ; details <- newMetaDetails TauTv
+       ; let name = mkSysTvName uniq (fsLit "w")
+             tyvar = (mkTcTyVar name kind details)
+       ; traceTc "newWildTyVar" (ppr tyvar)
+       ; return tyvar }
+
+{- *********************************************************************
+*                                                                      *
+             Kind inference for type declarations
+*                                                                      *
+********************************************************************* -}
+
+{- Note [The initial kind of a type constructor]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+kcLHsQTyVars is responsible for getting the initial kind of
+a type constructor.
+
+It has two cases:
+
+ * The TyCon has a CUSK.  In that case, find the full, final,
+   poly-kinded kind of the TyCon.  It's very like a term-level
+   binding where we have a complete type signature for the
+   function.
+
+ * It does not have a CUSK.  Find a monomorphic kind, with
+   unification variables in it; they will be generalised later.
+   It's very like a term-level binding where we do not have
+   a type signature (or, more accurately, where we have a
+   partial type signature), so we infer the type and generalise.
+-}
+
+
+------------------------------
 -- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete,
 -- user-supplied kind signature (CUSK), generalise the result.
 -- Used in 'getInitialKind' (for tycon kinds and other kinds)
@@ -1534,90 +1515,77 @@ kcLHsQTyVars :: Name              -- ^ of the thing being checked
              -> LHsQTyVars GhcRn
              -> TcM Kind          -- ^ The result kind
              -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon
-kcLHsQTyVars name flav cusk
+kcLHsQTyVars name flav cusk tvs thing_inside
+  | cusk      = kcLHsQTyVars_Cusk    name flav tvs thing_inside
+  | otherwise = kcLHsQTyVars_NonCusk name flav tvs thing_inside
+
+
+kcLHsQTyVars_Cusk, kcLHsQTyVars_NonCusk
+    :: Name              -- ^ of the thing being checked
+    -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
+    -> LHsQTyVars GhcRn
+    -> TcM Kind          -- ^ The result kind
+    -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon
+
+------------------------------
+kcLHsQTyVars_Cusk name flav
   user_tyvars@(HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kv_ns
                                            , hsq_dependent = dep_names }
                       , hsq_explicit = hs_tvs }) thing_inside
-  | cusk
-    -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls
+  -- CUSK case
+  -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls
   = addTyConFlavCtxt name flav $
     do { (scoped_kvs, (tc_tvs, res_kind))
-           <- solveEqualities                    $
-              tcImplicitQTKBndrs skol_info kv_ns $
-              kcLHsQTyVarBndrs cusk open_fam skol_info hs_tvs thing_inside
-
-       ; let class_tc_binders
-               | Just class_tc <- tyConFlavourAssoc_maybe flav
-               = tyConBinders class_tc  -- class has a CUSK, so these are zonked
-                                       -- and fully settled
-               | otherwise
-               = []
-
-             class_tv_set = mkVarSet (binderVars class_tc_binders)
-             local_specified = filterOut (`elemVarSet` class_tv_set) scoped_kvs
-               -- NB: local_specified are guaranteed to be in a well-scoped
-               -- order because of tcImplicitQTKBndrs
-
-         -- NB: candidateQTyVarsOfType is OK with unzonked input
-       ; candidates <- candidateQTyVarsOfType class_tv_set $
-                       mkSpecForAllTys local_specified $
-                       mkSpecForAllTys tc_tvs $
-                       res_kind
-               -- The type above is a bit wrong, in that we're using foralls for all
-               -- the tc_tvs, even those that aren't dependent. This is OK, though,
-               -- because we're building the type only to extract the variables to
-               -- quantify. We use mk_tc_binder below to get this right.
-
-       ; local_inferred <- quantifyTyVars class_tv_set candidates
-
-       ; local_specified <- mapM zonkTyCoVarKind local_specified
-       ; tc_tvs          <- mapM zonkTyCoVarKind tc_tvs
-       ; res_kind        <- zonkTcType res_kind
-
-       ; let dep_tv_set = tyCoVarsOfTypes (res_kind : map tyVarKind tc_tvs)
-             local_tcbs = concat [ mkNamedTyConBinders Inferred local_inferred
-                                 , mkNamedTyConBinders Specified local_specified
-                                 , map (mkRequiredTyConBinder dep_tv_set) tc_tvs ]
-
-             free_class_tv_set = tyCoVarsOfTypes (res_kind : map binderType local_tcbs)
-                                 `delVarSetList` map binderVar local_tcbs
-
-             used_class_tcbs = filter ((`elemVarSet` free_class_tv_set) . binderVar)
-                                      class_tc_binders
-
-              -- Suppose we have class C k where type F (x :: k). We can't have
-              -- k *required* in F, so it becomes Specified
-             to_invis_tcb tcb
-               | Required <- tyConBinderArgFlag tcb
-               = mkNamedTyConBinder Specified (binderVar tcb)
-               | otherwise
-               = tcb
-
-             used_class_tcbs_invis = map to_invis_tcb used_class_tcbs
-
-             all_tcbs = used_class_tcbs_invis ++ local_tcbs
-
+           <- pushTcLevelM_                               $
+              solveEqualities                             $
+              bindImplicitTKBndrs_Q_Skol kv_ns            $
+              bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $
+              thing_inside
+
+           -- Now, because we're in a CUSK,
+           -- we quantify over the mentioned kind vars
+       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs
+             all_kinds     = res_kind : map tyVarKind spec_req_tkvs
+
+       ; candidates <- candidateQTyVarsOfKinds all_kinds
+             -- 'candidates' are all the variables that we are going to
+             -- skolemise and then quantify over.  We do not include spec_req_tvs
+             -- because they are /already/ skolems
+
+       ; let inf_candidates = candidates `delCandidates` spec_req_tkvs
+
+       ; inferred <- quantifyTyVars emptyVarSet inf_candidates
+                     -- NB: 'inferred' comes back sorted in dependency order
+
+       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs
+       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs
+       ; res_kind   <- zonkTcType           res_kind
+
+       ; let mentioned_kv_set = candidateKindVars candidates
+             specified        = scopedSort scoped_kvs
+                                -- NB: maintain the L-R order of scoped_kvs
+
+             final_tc_binders =  mkNamedTyConBinders Inferred  inferred
+                              ++ mkNamedTyConBinders Specified specified
+                              ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs
+
+             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)
+             tycon = mkTcTyCon name (ppr user_tyvars)
+                               final_tc_binders
+                               res_kind
+                               all_tv_prs
+                               True {- it is generalised -} flav
          -- If the ordering from
          -- Note [Required, Specified, and Inferred for types] in TcTyClsDecls
          -- doesn't work, we catch it here, before an error cascade
-       ; checkValidTelescope all_tcbs (ppr user_tyvars)
+       ; checkValidTelescope tycon
 
-          -- If any of the all_kvs aren't actually mentioned in a binder's
+          -- If any of the specified tyvars aren't actually mentioned in a binder's
           -- kind (or the return kind), then we're in the CUSK case from
           -- Note [Free-floating kind vars]
-       ; let all_kvs = concat [ map binderVar used_class_tcbs_invis
-                              , local_inferred
-                              , local_specified ]
-
-             all_mentioned_tvs = dep_tv_set `unionVarSet`
-                                 tyCoVarsOfTypes (map tyVarKind all_kvs)
+       ; let unmentioned_kvs   = filterOut (`elemVarSet` mentioned_kv_set) specified
+       ; reportFloatingKvs name flav (map binderVar final_tc_binders) unmentioned_kvs
 
-             unmentioned_kvs   = filterOut (`elemVarSet` all_mentioned_tvs) all_kvs
-       ; reportFloatingKvs name flav (map binderVar all_tcbs) unmentioned_kvs
-
-       ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)
-             tycon = mkTcTyCon name (ppr user_tyvars) all_tcbs res_kind
-                               all_tv_prs True {- it is generalised -} flav
 
        ; traceTc "kcLHsQTyVars: cusk" $
          vcat [ text "name" <+> ppr name
@@ -1627,23 +1595,41 @@ kcLHsQTyVars name flav cusk
               , text "scoped_kvs" <+> ppr scoped_kvs
               , text "tc_tvs" <+> ppr tc_tvs
               , text "res_kind" <+> ppr res_kind
-              , text "all_tcbs" <+> ppr all_tcbs
-              , text "mkTyConKind all_tcbs res_kind"
-                <+> ppr (mkTyConKind all_tcbs res_kind)
+              , text "candidates" <+> ppr candidates
+              , text "inferred" <+> ppr inferred
+              , text "specified" <+> ppr specified
+              , text "final_tc_binders" <+> ppr final_tc_binders
+              , text "mkTyConKind final_tc_bndrs res_kind"
+                <+> ppr (mkTyConKind final_tc_binders res_kind)
               , text "all_tv_prs" <+> ppr all_tv_prs ]
 
        ; return tycon }
+  where
+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind
+              | otherwise            = AnyKind
 
-  | otherwise
+kcLHsQTyVars_Cusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"
+
+------------------------------
+kcLHsQTyVars_NonCusk name flav
+  user_tyvars@(HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kv_ns
+                                           , hsq_dependent = dep_names }
+                      , hsq_explicit = hs_tvs }) thing_inside
+  -- Non_CUSK case
+  -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls
   = do { (scoped_kvs, (tc_tvs, res_kind))
-           -- Why kcImplicitTKBndrs which uses newTyVarTyVar?
-           -- See Note [Kind generalisation and TyVarTvs]
-           <- kcImplicitTKBndrs kv_ns $
-              kcLHsQTyVarBndrs cusk open_fam skol_info hs_tvs thing_inside
+           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?
+           -- See Note [Inferring kinds for type declarations] in TcTyClsDecls
+           <- bindImplicitTKBndrs_Q_Tv kv_ns            $
+              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $
+              thing_inside
+              -- Why "_Tv" not "_Skol"? See third wrinkle in
+              -- Note [Inferring kinds for type declarations] in TcTyClsDecls,
 
        ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they
                -- might unify with kind vars in other types in a mutually
-               -- recursive group. See Note [Kind generalisation and TyVarTvs]
+               -- recursive group.
+               -- See Note [Inferring kinds for type declarations] in TcTyClsDecls
              tc_binders = zipWith mk_tc_binder hs_tvs tc_tvs
                -- Also, note that tc_binders has the tyvars from only the
                -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]
@@ -1655,11 +1641,12 @@ kcLHsQTyVars name flav cusk
 
        ; traceTc "kcLHsQTyVars: not-cusk" $
          vcat [ ppr name, ppr kv_ns, ppr hs_tvs, ppr dep_names
+              , ppr scoped_kvs
               , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]
        ; return tycon }
   where
-    open_fam = tcFlavourIsOpen flav
-    skol_info = TyConSkol flav name
+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind
+              | otherwise            = AnyKind
 
     mk_tc_binder :: LHsTyVarBndr GhcRn -> TyVar -> TyConBinder
     -- See Note [Dependent LHsQTyVars]
@@ -1669,79 +1656,8 @@ kcLHsQTyVars name flav cusk
        | otherwise
        = mkAnonTyConBinder tv
 
-kcLHsQTyVars _ _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"
-
-kcLHsQTyVarBndrs :: Bool   -- True <=> bump the TcLevel when bringing vars into scope
-                 -> Bool   -- True <=> Default un-annotated tyvar
-                           --          binders to kind *
-                 -> SkolemInfo
-                 -> [LHsTyVarBndr GhcRn]
-                 -> TcM r
-                 -> TcM ([TyVar], r)
--- There may be dependency between the explicit "ty" vars.
--- So, we have to handle them one at a time.
-kcLHsQTyVarBndrs _ _ _ [] thing
-  = do { stuff <- thing; return ([], stuff) }
-
-kcLHsQTyVarBndrs cusk open_fam skol_info (L _ hs_tv : hs_tvs) thing
-  = do { tv_pair@(tv, _) <- kc_hs_tv hs_tv
-               -- NB: Bring all tvs into scope, even non-dependent ones,
-               -- as they're needed in type synonyms, data constructors, etc.
-
-       ; (tvs, stuff) <- bind_unless_scoped tv_pair $
-                         kcLHsQTyVarBndrs cusk open_fam skol_info hs_tvs $
-                         thing
-
-       ; return ( tv : tvs, stuff ) }
-  where
-    -- | Bind the tyvar in the env't unless the bool is True
-    bind_unless_scoped :: (TcTyVar, Bool) -> TcM a -> TcM a
-    bind_unless_scoped (_, True)   thing_inside = thing_inside
-    bind_unless_scoped (tv, False) thing_inside
-      | cusk      = scopeTyVars skol_info [tv] thing_inside
-      | otherwise = tcExtendTyVarEnv      [tv] thing_inside
-         -- These variables haven't settled down yet, so we don't want to bump
-         -- the TcLevel. If we do, then we'll have metavars of too high a level
-         -- floating about. Changing this causes many, many failures in the
-         -- `dependent` testsuite directory.
-
-    kc_hs_tv :: HsTyVarBndr GhcRn -> TcM (TcTyVar, Bool)
-      -- Special handling for the case where the binder is already in scope
-      -- See Note [Associated type tyvar names] in Class and
-      --     Note [TyVar binders for associated decls] in HsDecls
-    kc_hs_tv (UserTyVar _ (L _ name))
-      = do { mb_tv <- tcLookupLcl_maybe name
-           ; case mb_tv of  -- See Note [TyVar binders for associated decls]
-                Just (ATyVar _ tv) -> return (tv, True)
-                _ -> do { kind <- if open_fam
-                                  then return liftedTypeKind
-                                  else newMetaKindVar
-                                  -- Open type/data families default their variables
-                                  -- variables to kind *.  But don't default in-scope
-                                  -- class tyvars, of course
-                        ; tv <- new_tv name kind
-                        ; return (tv, False) } }
-
-    kc_hs_tv (KindedTyVar _ lname@(L _ name) lhs_kind)
-      = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt name) lhs_kind
-           ; mb_tv <- tcLookupLcl_maybe name
-           ; case mb_tv of
-               Just (ATyVar _ tv)
-                 -> do { discardResult $
-                           unifyKind (Just (HsTyVar noExt NotPromoted lname))
-                                     kind (tyVarKind tv)
-                       ; return (tv, True) }
-               _ -> do { tv <- new_tv name kind
-                       ; return (tv, False) } }
-
-    kc_hs_tv (XTyVarBndr{}) = panic "kc_hs_tv"
-
-
-    new_tv :: Name -> Kind -> TcM TcTyVar
-    new_tv
-      | cusk      = newSkolemTyVar
-      | otherwise = newTyVarTyVar
-          -- Third wrinkle in Note [Kind generalisation and TyVarTvs]
+kcLHsQTyVars_NonCusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"
+
 
 {- Note [Kind-checking tyvar binders for associated types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1759,7 +1675,7 @@ See Note [Associated type tyvar names] in Class and
 
 We must do the same for family instance decls, where the in-scope
 variables may be bound by the enclosing class instance decl.
-Hence the use of tcImplicitQTKBndrs in tcFamTyPats.
+Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen.
 
 Note [Kind variable ordering for associated types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1797,41 +1713,64 @@ these first.
 -}
 
 
+{- *********************************************************************
+*                                                                      *
+             Expected kinds
+*                                                                      *
+********************************************************************* -}
+
+-- | Describes the kind expected in a certain context.
+data ContextKind = TheKind Kind   -- ^ a specific kind
+                 | AnyKind        -- ^ any kind will do
+                 | OpenKind       -- ^ something of the form @TYPE _@
+
+-----------------------
+newExpectedKind :: ContextKind -> TcM Kind
+newExpectedKind (TheKind k) = return k
+newExpectedKind AnyKind     = newMetaKindVar
+newExpectedKind OpenKind    = newOpenTypeKind
+
+-----------------------
+expectedKindInCtxt :: UserTypeCtxt -> ContextKind
+-- Depending on the context, we might accept any kind (for instance, in a TH
+-- splice), or only certain kinds (like in type signatures).
+expectedKindInCtxt (TySynCtxt _)   = AnyKind
+expectedKindInCtxt ThBrackCtxt     = AnyKind
+expectedKindInCtxt GhciCtxt        = AnyKind
+-- The types in a 'default' decl can have varying kinds
+-- See Note [Extended defaults]" in TcEnv
+expectedKindInCtxt DefaultDeclCtxt     = AnyKind
+expectedKindInCtxt TypeAppCtxt         = AnyKind
+expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind
+expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind
+expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind
+expectedKindInCtxt _                   = OpenKind
+
+
+{- *********************************************************************
+*                                                                      *
+             Bringing type variables into scope
+*                                                                      *
+********************************************************************* -}
+
 --------------------------------------
 -- Implicit binders
 --------------------------------------
 
--- | Bring implicitly quantified type/kind variables into scope during
--- kind checking. Uses TyVarTvs, as per Note [Use TyVarTvs in kind-checking pass]
--- in TcTyClsDecls.
-kcImplicitTKBndrs :: [Name]     -- of the vars
-                  -> TcM a
-                  -> TcM ([TcTyVar], a)  -- returns the tyvars created
-                                         -- these are *not* dependency ordered
-kcImplicitTKBndrs var_ns thing_inside
-  -- NB: Just use tyvars that are in scope, if any. Otherwise, we
-  -- get #15711, where GHC forgets that a variable used in an associated
-  -- type is the same as the one used in the enclosing class
-  = do { tkvs_pairs <- mapM (newFlexiKindedQTyVar newTyVarTyVar) var_ns
-       ; let tkvs_to_scope = [ tkv | (tkv, True) <- tkvs_pairs ]
-       ; result <- tcExtendTyVarEnv tkvs_to_scope thing_inside
-       ; return (map fst tkvs_pairs, result) }
-
-tcImplicitTKBndrs, tcImplicitTKBndrsSig, tcImplicitQTKBndrs
-  :: SkolemInfo
-  -> [Name]
+bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,
+  bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv
+  :: [Name]
   -> TcM a
   -> TcM ([TcTyVar], a)
-tcImplicitTKBndrs    = tcImplicitTKBndrsX newFlexiKindedSkolemTyVar
-tcImplicitTKBndrsSig = tcImplicitTKBndrsX newFlexiKindedTyVarTyVar
-tcImplicitQTKBndrs   = tcImplicitTKBndrsX
-                         (\nm -> fst <$> newFlexiKindedQTyVar newSkolemTyVar nm)
-
-tcImplicitTKBndrsX :: (Name -> TcM TcTyVar) -- new_tv function
-                   -> SkolemInfo
-                   -> [Name]
-                   -> TcM a
-                   -> TcM ([TcTyVar], a)   -- these tyvars are dependency-ordered
+bindImplicitTKBndrs_Skol   = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar
+bindImplicitTKBndrs_Tv     = bindImplicitTKBndrsX newFlexiKindedTyVarTyVar
+bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar)
+bindImplicitTKBndrs_Q_Tv   = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar)
+
+bindImplicitTKBndrsX :: (Name -> TcM TcTyVar) -- new_tv function
+                    -> [Name]
+                    -> TcM a
+                    -> TcM ([TcTyVar], a)   -- these tyvars are dependency-ordered
 -- * Guarantees to call solveLocalEqualities to unify
 --   all constraints from thing_inside.
 --
@@ -1841,39 +1780,19 @@ tcImplicitTKBndrsX :: (Name -> TcM TcTyVar) -- new_tv function
 --
 -- * Returned TcTyVars have zonked kinds
 --   See Note [Keeping scoped variables in order: Implicit]
-tcImplicitTKBndrsX new_tv skol_info tv_names thing_inside
-  | null tv_names -- Short cut for the common case where there
-                  -- are no implicit type variables to bind
-  = do { result <- solveLocalEqualities thing_inside
-       ; return ([], result) }
-
-  | otherwise
-  = do { (skol_tvs, result)
-           <- solveLocalEqualities $
-              checkTvConstraints skol_info Nothing $
-              do { tkvs <- mapM new_tv tv_names
-                 ; result <- tcExtendTyVarEnv tkvs thing_inside
-                 ; return (tkvs, result) }
-
-       ; skol_tvs <- mapM zonkTcTyCoVarBndr skol_tvs
-          -- use zonkTcTyCoVarBndr because a skol_tv might be a TyVarTv
-
-          -- do a stable topological sort, following
-          -- Note [Ordering of implicit variables] in RnTypes
-       ; let final_tvs = scopedSort skol_tvs
-       ; traceTc "tcImplicitTKBndrs" (ppr tv_names $$ ppr final_tvs)
-       ; return (final_tvs, result) }
-
-newFlexiKindedQTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM (TcTyVar, Bool)
--- Make a new tyvar for an implicit binder in a type/class/type
--- instance declaration, with a flexi-kind
--- But check for in-scope-ness, and if so return that instead
--- Returns True as second return value iff this created a real new tyvar
-newFlexiKindedQTyVar mk_tv name
+bindImplicitTKBndrsX new_tv tv_names thing_inside
+  = do { tkvs <- mapM new_tv tv_names
+       ; result <- tcExtendTyVarEnv tkvs thing_inside
+       ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs)
+       ; return (tkvs, result) }
+
+newImplicitTyVarQ :: (Name -> TcM TcTyVar) ->  Name -> TcM TcTyVar
+-- Behave like new_tv, except that if the tyvar is in scope, use it
+newImplicitTyVarQ new_tv name
   = do { mb_tv <- tcLookupLcl_maybe name
        ; case mb_tv of
-           Just (ATyVar _ tv) -> return (tv, False)
-           _ -> (, True) <$> newFlexiKindedTyVar mk_tv name }
+           Just (ATyVar _ tv) -> return tv
+           _ -> new_tv name }
 
 newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar
 newFlexiKindedTyVar new_tv name
@@ -1890,126 +1809,132 @@ newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar
 -- Explicit binders
 --------------------------------------
 
--- | Used during the "kind-checking" pass in TcTyClsDecls only,
--- and even then only for data-con declarations.
--- See Note [Use TyVarTvs in kind-checking pass] in TcTyClsDecls
-kcExplicitTKBndrs :: [LHsTyVarBndr GhcRn]
-                  -> TcM a
-                  -> TcM a
-kcExplicitTKBndrs [] thing_inside = thing_inside
-kcExplicitTKBndrs (L _ hs_tv : hs_tvs) thing_inside
-  = do { tv <- tcHsTyVarBndr newTyVarTyVar hs_tv
-       ; tcExtendTyVarEnv [tv] $
-         kcExplicitTKBndrs hs_tvs thing_inside }
-
-tcExplicitTKBndrs :: SkolemInfo
-                  -> [LHsTyVarBndr GhcRn]
-                  -> TcM a
-                  -> TcM ([TcTyVar], a)
-tcExplicitTKBndrs skol_info hs_tvs thing_inside
--- Used for the forall'd binders in type signatures of various kinds:
---     - function signatures
---     - data con signatures in GADT-style decls
---     - pattern synonym signatures
---     - expression type signatures
---
--- Specifically NOT used for the binders of a data type
--- or type family decl. So the forall'd variables always /shadow/
--- anything already in scope, and the complications of
--- tcHsQTyVarName to not apply.
---
--- This function brings into scope a telescope of binders as written by
--- the user. At first blush, it would then seem that we should bring
--- them into scope one at a time, bumping the TcLevel each time.
--- (Recall that we bump the level to prevent skolem escape from happening.)
--- However, this leads to terrible error messages, because we end up
--- failing to unify with some `k0`. Better would be to allow type inference
--- to work, potentially creating a skolem-escape problem, and then to
--- notice that the telescope is out of order. That's what we do here,
--- following the logic of tcImplicitTKBndrsX.
--- See also Note [Keeping scoped variables in order: Explicit]
---
--- No cloning: returned TyVars have the same Name as the incoming LHsTyVarBndrs
-  | null hs_tvs  -- Short cut that avoids creating an implication
-                 -- constraint in the common case where none is needed
-  = do { result <- thing_inside
-       ; return ([], result) }
+bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv
+    :: [LHsTyVarBndr GhcRn]
+    -> TcM a
+    -> TcM ([TcTyVar], a)
 
-  | otherwise
-  = do { (skol_tvs, result) <- checkTvConstraints skol_info (Just doc) $
-                               bind_tvbs hs_tvs
+bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar)
+bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (tcHsTyVarBndr newTyVarTyVar)
 
-       ; traceTc "tcExplicitTKBndrs" $
-           vcat [ text "Hs vars:" <+> ppr hs_tvs
-                , text "tvs:" <+> pprTyVars skol_tvs ]
+bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv
+    :: ContextKind
+    -> [LHsTyVarBndr GhcRn]
+    -> TcM a
+    -> TcM ([TcTyVar], a)
 
-       ; return (skol_tvs, result) }
+bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar)
+bindExplicitTKBndrs_Q_Tv   ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar)
 
+-- | Used during the "kind-checking" pass in TcTyClsDecls only,
+-- and even then only for data-con declarations.
+bindExplicitTKBndrsX
+    :: (HsTyVarBndr GhcRn -> TcM TcTyVar)
+    -> [LHsTyVarBndr GhcRn]
+    -> TcM a
+    -> TcM ([TcTyVar], a)
+bindExplicitTKBndrsX tc_tv hs_tvs thing_inside
+  = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs)
+       ; go hs_tvs }
   where
-    bind_tvbs [] = do { result <- thing_inside
-                      ; return ([], result) }
-    bind_tvbs (L _ tvb : tvbs)
-      = do { tv <- tcHsTyVarBndr newSkolemTyVar tvb
-           ; tcExtendTyVarEnv [tv] $
-        do { (tvs, result) <- bind_tvbs tvbs
-           ; return (tv : tvs, result) }}
-
-    doc = sep (map ppr hs_tvs)
+    go [] = do { res <- thing_inside
+               ; return ([], res) }
+    go (L _ hs_tv : hs_tvs)
+       = do { tv <- tc_tv hs_tv
+            ; (tvs, res) <- tcExtendTyVarEnv [tv] (go hs_tvs)
+            ; return (tv:tvs, res) }
 
 -----------------
 tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)
               -> HsTyVarBndr GhcRn -> TcM TcTyVar
--- Return a TcTyVar, built using the provided function
--- Typically the Kind inside the HsTyVarBndr will be a tyvar
--- with a mutable kind in it.
---
 -- Returned TcTyVar has the same name; no cloning
 tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm))
-  = newFlexiKindedTyVar new_tv tv_nm
+  = do { kind <- newMetaKindVar
+       ; new_tv tv_nm kind }
 tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)
   = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind
        ; new_tv tv_nm kind }
 tcHsTyVarBndr _ (XTyVarBndr _) = panic "tcHsTyVarBndr"
 
 -----------------
-newWildTyVar :: Name -> TcM TcTyVar
--- ^ New unification variable for a wildcard
-newWildTyVar _name
-  = do { kind <- newMetaKindVar
-       ; uniq <- newUnique
-       ; details <- newMetaDetails TauTv
-       ; let name = mkSysTvName uniq (fsLit "w")
-             tyvar = (mkTcTyVar name kind details)
-       ; traceTc "newWildTyVar" (ppr tyvar)
-       ; return tyvar }
+tcHsQTyVarBndr :: ContextKind
+               -> (Name -> Kind -> TcM TyVar)
+               -> HsTyVarBndr GhcRn -> TcM TcTyVar
+-- Just like tcHsTyVarBndr, but also
+--   - uses the in-scope TyVar from class, if it exists
+--   - takes a ContextKind to use for the no-sig case
+tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ (L _ tv_nm))
+  = do { mb_tv <- tcLookupLcl_maybe tv_nm
+       ; case mb_tv of
+           Just (ATyVar _ tv) -> return tv
+           _ -> do { kind <- newExpectedKind ctxt_kind
+                   ; new_tv tv_nm kind } }
 
---------------------------
--- Bringing tyvars into scope
---------------------------
+tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)
+  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind
+       ; mb_tv <- tcLookupLcl_maybe tv_nm
+       ; case mb_tv of
+           Just (ATyVar _ tv)
+             -> do { discardResult $ unifyKind (Just hs_tv)
+                                        kind (tyVarKind tv)
+                       -- This unify rejects:
+                       --    class C (m :: * -> *) where
+                       --      type F (m :: *) = ...
+                   ; return tv }
+
+           _ -> new_tv tv_nm kind }
+  where
+    hs_tv = HsTyVar noExt NotPromoted (noLoc tv_nm)
+            -- Used for error messages only
 
--- | Bring tyvars into scope, wrapping the thing_inside in an implication
--- constraint. The implication constraint is necessary to provide SkolemInfo
--- for the tyvars and to ensure that no unification variables made outside
--- the scope of these tyvars (i.e. lower TcLevel) unify with the locally-scoped
--- tyvars (i.e. higher TcLevel).
---
--- INVARIANT: The thing_inside must check only types, never terms.
---
--- Use this (not tcExtendTyVarEnv) wherever you expect a Λ or ∀ in Core.
--- Use tcExtendTyVarEnv otherwise.
-scopeTyVars :: SkolemInfo -> [TcTyVar] -> TcM a -> TcM a
-scopeTyVars skol_info tvs = scopeTyVars2 skol_info [(tyVarName tv, tv) | tv <- tvs]
-
--- | Like 'scopeTyVars', but allows you to specify different scoped names
--- than the Names stored within the tyvars.
-scopeTyVars2 :: SkolemInfo -> [(Name, TcTyVar)] -> TcM a -> TcM a
-scopeTyVars2 skol_info prs thing_inside
-  = fmap snd $ -- discard the TcEvBinds, which will always be empty
-    checkConstraints skol_info (map snd prs) [{- no EvVars -}] $
-    tcExtendNameTyVarEnv prs $
-    thing_inside
+tcHsQTyVarBndr _ _ (XTyVarBndr _) = panic "tcHsTyVarBndr"
+
+
+--------------------------------------
+-- Binding type/class variables in the
+-- kind-checking and typechecking phases
+--------------------------------------
+
+bindTyClTyVars :: Name
+               -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
+-- ^ Used for the type variables of a type or class decl
+-- in the "kind checking" and "type checking" pass,
+-- but not in the initial-kind run.
+bindTyClTyVars tycon_name thing_inside
+  = do { tycon <- kcLookupTcTyCon tycon_name
+       ; let scoped_prs = tcTyConScopedTyVars tycon
+             res_kind   = tyConResKind tycon
+             binders    = tyConBinders tycon
+       ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders)
+       ; tcExtendNameTyVarEnv scoped_prs $
+         thing_inside binders res_kind }
+
+-- getInitialKind has made a suitably-shaped kind for the type or class
+-- Look it up in the local environment. This is used only for tycons
+-- that we're currently type-checking, so we're sure to find a TcTyCon.
+kcLookupTcTyCon :: Name -> TcM TcTyCon
+kcLookupTcTyCon nm
+  = do { tc_ty_thing <- tcLookup nm
+       ; return $ case tc_ty_thing of
+           ATcTyCon tc -> tc
+           _           -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) }
+
+
+{- *********************************************************************
+*                                                                      *
+             Kind generalisation
+*                                                                      *
+********************************************************************* -}
+
+zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]
+zonkAndScopedSort spec_tkvs
+  = do { spec_tkvs <- mapM zonkTcTyCoVarBndr spec_tkvs
+          -- Use zonkTcTyCoVarBndr because a skol_tv might be a TyVarTv
+
+       -- Do a stable topological sort, following
+       -- Note [Ordering of implicit variables] in RnTypes
+       ; return (scopedSort spec_tkvs) }
 
-------------------
 kindGeneralize :: TcType -> TcM [KindVar]
 -- Quantify the free kind variables of a kind or type
 -- In the latter case the type is closed, so it has no free
@@ -2017,7 +1942,18 @@ kindGeneralize :: TcType -> TcM [KindVar]
 -- Input needn't be zonked.
 -- NB: You must call solveEqualities or solveLocalEqualities before
 -- kind generalization
-kindGeneralize = kindGeneralizeLocal emptyWC
+--
+-- NB: this function is just a specialised version of
+--        kindGeneralizeLocal emptyWC kind_or_type
+--
+kindGeneralize kind_or_type
+  = do { kt <- zonkTcType kind_or_type
+       ; traceTc "kindGeneralise1" (ppr kt)
+       ; dvs <- candidateQTyVarsOfKind kind_or_type
+       ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked
+       ; traceTc "kindGeneralize" (vcat [ ppr kind_or_type
+                                        , ppr dvs ])
+       ; quantifyTyVars gbl_tvs dvs }
 
 -- | This variant of 'kindGeneralize' refuses to generalize over any
 -- variables free in the given WantedConstraints. Instead, it promotes
@@ -2039,17 +1975,38 @@ kindGeneralizeLocal wanted kind_or_type
          -- use the "Kind" variant here, as any types we see
          -- here will already have all type variables quantified;
          -- thus, every free variable is really a kv, never a tv.
-       ; dvs <- candidateQTyVarsOfKind mono_tvs kind_or_type
+       ; dvs <- candidateQTyVarsOfKind kind_or_type
 
-       ; traceTc "kindGeneralizeLocal" (vcat [ ppr wanted
-                                             , ppr kind_or_type
-                                             , ppr constrained
-                                             , ppr mono_tvs
-                                             , ppr dvs ])
+       ; traceTc "kindGeneralizeLocal" $
+         vcat [ text "Wanted:" <+> ppr wanted
+              , text "Kind or type:" <+> ppr kind_or_type
+              , text "tcvs of wanted:" <+> pprTyVars (nonDetEltsUniqSet (tyCoVarsOfWC wanted))
+              , text "constrained:" <+> pprTyVars (nonDetEltsUniqSet constrained)
+              , text "mono_tvs:" <+> pprTyVars (nonDetEltsUniqSet mono_tvs)
+              , text "dvs:" <+> ppr dvs ]
 
        ; quantifyTyVars mono_tvs dvs }
 
-{-
+{- Note [Levels and generalisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f x = e
+with no type signature. We are currently at level i.
+We must
+  * Push the level to level (i+1)
+  * Allocate a fresh alpha[i+1] for the result type
+  * Check that e :: alpha[i+1], gathering constraint WC
+  * Solve WC as far as possible
+  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]
+  * Find the free variables with level > i, in this case gamma[i]
+  * Skolemise those free variables and quantify over them, giving
+       f :: forall g. beta[i-1] -> g
+  * Emit the residiual constraint wrapped in an implication for g,
+    thus   forall g. WC
+
+All of this happens for types too.  Consider
+  f :: Int -> (forall a. Proxy a -> Int)
+
 Note [Kind generalisation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 We do kind generalisation only at the outer level of a type signature.
@@ -2090,186 +2047,12 @@ look through unification variables!
 
 Hence using zonked_kinds when forming tvs'.
 
-Note [Free-floating kind vars]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-  data T = MkT (forall (a :: k). Proxy a)
-  -- from test ghci/scripts/T7873
-
-This is not an existential datatype, but a higher-rank one (the forall
-to the right of MkT). Also consider
-
-  data S a = MkS (Proxy (a :: k))
-
-According to the rules around implicitly-bound kind variables, in both
-cases those k's scope over the whole declaration. The renamer grabs
-it and adds it to the hsq_implicits field of the HsQTyVars of the
-tycon. So it must be in scope during type-checking, but we want to
-reject T while accepting S.
-
-Why reject T? Because the kind variable isn't fixed by anything. For
-a variable like k to be implicit, it needs to be mentioned in the kind
-of a tycon tyvar. But it isn't.
-
-Why accept S? Because kind inference tells us that a has kind k, so it's
-all OK.
-
-Our approach depends on whether or not the datatype has a CUSK.
-
-Non-CUSK: In the first pass (kcTyClTyVars) we just bring
-k into scope. In the second pass (tcTyClTyVars),
-we check to make sure that k has been unified with some other variable
-(or generalized over, making k into a skolem). If it hasn't been, then
-it must be a free-floating kind var. Error.
-
-CUSK: When we determine the tycon's final, never-to-be-changed kind
-in kcLHsQTyVars, we check to make sure all implicitly-bound kind
-vars are indeed mentioned in a kind somewhere. If not, error.
-
-We also perform free-floating kind var analysis for type family instances
-(see #13985). Here is an interesting example:
-
-    type family   T :: k
-    type instance T = (Nothing :: Maybe a)
-
-Upon a cursory glance, it may appear that the kind variable `a` is
-free-floating above, since there are no (visible) LHS patterns in `T`. However,
-there is an *invisible* pattern due to the return kind, so inside of GHC, the
-instance looks closer to this:
-
-    type family T @k :: k
-    type instance T @(Maybe a) = (Nothing :: Maybe a)
-
-Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in
-fact not free-floating. Contrast that with this example:
-
-    type instance T = Proxy (Nothing :: Maybe a)
-
-This would looks like this inside of GHC:
-
-    type instance T @(*) = Proxy (Nothing :: Maybe a)
-
-So this time, `a` is neither bound by a visible nor invisible type pattern on
-the LHS, so it would be reported as free-floating.
-
-Finally, here's one more brain-teaser (from #9574). In the example below:
-
-    class Funct f where
-      type Codomain f :: *
-    instance Funct ('KProxy :: KProxy o) where
-      type Codomain 'KProxy = NatTr (Proxy :: o -> *)
-
-As it turns out, `o` is not free-floating in this example. That is because `o`
-bound by the kind signature of the LHS type pattern 'KProxy. To make this more
-obvious, one can also write the instance like so:
-
-    instance Funct ('KProxy :: KProxy o) where
-      type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *)
-
 -}
 
---------------------
--- getInitialKind has made a suitably-shaped kind for the type or class
--- Look it up in the local environment. This is used only for tycons
--- that we're currently type-checking, so we're sure to find a TcTyCon.
-kcLookupTcTyCon :: Name -> TcM TcTyCon
-kcLookupTcTyCon nm
-  = do { tc_ty_thing <- tcLookup nm
-       ; return $ case tc_ty_thing of
-           ATcTyCon tc -> tc
-           _           -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) }
-
------------------------
--- | Bring tycon tyvars into scope. This is used during the "kind-checking"
--- pass in TcTyClsDecls. (Never in getInitialKind, never in the
--- "type-checking"/desugaring pass.)
--- Never emits constraints, though the thing_inside might.
-kcTyClTyVars :: Name -> TcM a -> TcM a
-kcTyClTyVars tycon_name thing_inside
-  -- See Note [Use TyVarTvs in kind-checking pass] in TcTyClsDecls
-  = do { tycon <- kcLookupTcTyCon tycon_name
-       ; tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ thing_inside }
-
-tcTyClTyVars :: Name
-             -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
--- ^ Used for the type variables of a type or class decl
--- on the second full pass (type-checking/desugaring) in TcTyClDecls.
--- This is *not* used in the initial-kind run, nor in the "kind-checking" pass.
--- Accordingly, everything passed to the continuation is fully zonked.
---
--- (tcTyClTyVars T [a,b] thing_inside)
---   where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> *
---   calls thing_inside with arguments
---      [k1,k2,a,b] [k1:*, k2:*, Anon (k1 -> *), Anon k1] (k2 -> *)
---   having also extended the type environment with bindings
---   for k1,k2,a,b
---
--- Never emits constraints.
---
--- The LHsTyVarBndrs is always user-written, and the full, generalised
--- kind of the tycon is available in the local env.
-tcTyClTyVars tycon_name thing_inside
-  = do { tycon <- kcLookupTcTyCon tycon_name
-
-       -- Do checks on scoped tyvars
-       -- See Note [Free-floating kind vars]
-       ; let flav = tyConFlavour tycon
-             scoped_prs = tcTyConScopedTyVars tycon
-             scoped_tvs = map snd scoped_prs
-             still_sig_tvs = filter isTyVarTyVar scoped_tvs
-
-       ; mapM_ report_sig_tv_err (findDupTyVarTvs scoped_prs)
-
-       ; checkNoErrs $ reportFloatingKvs tycon_name flav
-                                         scoped_tvs still_sig_tvs
-
-       ; let res_kind   = tyConResKind tycon
-             binders    = correct_binders (tyConBinders tycon) res_kind
-       ; traceTc "tcTyClTyVars" (ppr tycon_name <+> ppr binders)
-       ; scopeTyVars2 (TyConSkol flav tycon_name) scoped_prs $
-         thing_inside binders res_kind }
-  where
-    report_sig_tv_err (n1, n2)
-      = setSrcSpan (getSrcSpan n2) $
-        addErrTc (text "Couldn't match" <+> quotes (ppr n1)
-                        <+> text "with" <+> quotes (ppr n2))
-
-    -- Given some TyConBinders and a TyCon's result kind, make sure that the
-    -- correct any wrong Named/Anon choices. For example, consider
-    --   type Syn k = forall (a :: k). Proxy a
-    -- At first, it looks like k should be named -- after all, it appears on the RHS.
-    -- However, the correct kind for Syn is (* -> *).
-    -- (Why? Because k is the kind of a type, so k's kind is *. And the RHS also has
-    -- kind *.) See also #13963.
-    correct_binders :: [TyConBinder] -> Kind -> [TyConBinder]
-    correct_binders binders kind
-      = binders'
-      where
-        (_, binders') = mapAccumR go (tyCoVarsOfType kind) binders
-
-        go :: TyCoVarSet -> TyConBinder -> (TyCoVarSet, TyConBinder)
-        go fvs binder
-          | isNamedTyConBinder binder
-          , not (tv `elemVarSet` fvs)
-          = (new_fvs, mkAnonTyConBinder tv)
-
-          | not (isNamedTyConBinder binder)
-          , tv `elemVarSet` fvs
-          = (new_fvs, mkNamedTyConBinder Required tv)
-             -- always Required, because it was anonymous (i.e. visible) previously
-
-          | otherwise
-          = (new_fvs, binder)
-
-          where
-            tv      = binderVar binder
-            new_fvs = fvs `delVarSet` tv `unionVarSet` tyCoVarsOfType (tyVarKind tv)
-
 -----------------------------------
-tcDataKindSig :: [TyConBinder]
-              -> Kind
-              -> TcM ([TyConBinder], Kind)
+etaExpandAlgTyCon :: [TyConBinder]
+                  -> Kind
+                  -> TcM ([TyConBinder], Kind)
 -- GADT decls can have a (perhaps partial) kind signature
 --      e.g.  data T a :: * -> * -> * where ...
 -- This function makes up suitable (kinded) TyConBinders for the
@@ -2278,7 +2061,7 @@ tcDataKindSig :: [TyConBinder]
 -- Never emits constraints.
 -- It's a little trickier than you might think: see
 -- Note [TyConBinders for the result kind signature of a data type]
-tcDataKindSig tc_bndrs kind
+etaExpandAlgTyCon tc_bndrs kind
   = do  { loc     <- getSrcSpanM
         ; uniqs   <- newUniqueSupply
         ; rdr_env <- getLocalRdrEnv
@@ -2322,13 +2105,37 @@ badKindSig check_for_type kind
                text "return kind" ])
         2 (ppr kind)
 
+tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]
+-- Result is in 1-1 correpondence with orig_args
+tcbVisibilities tc orig_args
+  = go (tyConKind tc) init_subst orig_args
+  where
+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args))
+    go _ _ []
+      = []
+
+    go fun_kind subst all_args@(arg : args)
+      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind
+      = case tcb of
+          Anon _              -> AnonTCB      : go inner_kind subst  args
+          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args
+                 where
+                    subst' = extendTCvSubst subst tv arg
+
+      | not (isEmptyTCvSubst subst)
+      = go (substTy subst fun_kind) init_subst all_args
+
+      | otherwise
+      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)
+
+
 {- Note [TyConBinders for the result kind signature of a data type]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Given
   data T (a::*) :: * -> forall k. k -> *
 we want to generate the extra TyConBinders for T, so we finally get
   (a::*) (b::*) (k::*) (c::k)
-The function tcDataKindSig generates these extra TyConBinders from
+The function etaExpandAlgTyCon generates these extra TyConBinders from
 the result kind signature.
 
 We need to take care to give the TyConBinders
@@ -2393,8 +2200,8 @@ tcHsPartialSigType ctxt sig_ty
   = addSigCtxt ctxt hs_ty $
     do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau)))
             <- tcWildCardBinders sig_wcs $ \ wcs ->
-               tcImplicitTKBndrsSig skol_info implicit_hs_tvs      $
-               tcExplicitTKBndrs    skol_info explicit_hs_tvs      $
+               bindImplicitTKBndrs_Tv implicit_hs_tvs       $
+               bindExplicitTKBndrs_Tv explicit_hs_tvs       $
                do {   -- Instantiate the type-class context; but if there
                       -- is an extra-constraints wildcard, just discard it here
                     (theta, wcx) <- tcPartialContext hs_ctxt
@@ -2424,18 +2231,18 @@ tcHsPartialSigType ctxt sig_ty
          -- everything (and solved equalities in the tcImplicit call)
          -- we need to promote the TyVarTvs so we don't violate the TcLevel
          -- invariant
-       ; all_tvs <- mapM zonkPromoteTyCoVarBndr (implicit_tvs ++ explicit_tvs)
-            -- zonkPromoteTyCoVarBndr deals well with TyVarTvs
+       ; implicit_tvs <- zonkAndScopedSort implicit_tvs
+       ; explicit_tvs <- mapM zonkTcTyCoVarBndr explicit_tvs
+       ; theta        <- mapM zonkTcType theta
+       ; tau          <- zonkTcType tau
 
-       ; theta   <- mapM zonkPromoteType theta
-       ; tau     <- zonkPromoteType tau
+       ; let all_tvs = implicit_tvs ++ explicit_tvs
 
        ; checkValidType ctxt (mkSpecForAllTys all_tvs $ mkPhiTy theta tau)
 
        ; traceTc "tcHsPartialSigType" (ppr all_tvs)
        ; return (wcs, wcx, tv_names, all_tvs, theta, tau) }
-  where
-    skol_info   = SigTypeSkol ctxt
+
 tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPartialSigType"
 tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType"
 
@@ -2735,18 +2542,6 @@ zonkPromoteTcTyVar tv
 zonkPromoteTyCoVarKind :: TyCoVar -> TcM TyCoVar
 zonkPromoteTyCoVarKind = updateTyVarKindM zonkPromoteType
 
-zonkPromoteTyCoVarBndr :: TyCoVar -> TcM TyCoVar
-zonkPromoteTyCoVarBndr tv
-  | isTyVarTyVar tv
-  = tcGetTyVar "zonkPromoteTyCoVarBndr TyVarTv" <$> zonkPromoteTcTyVar tv
-
-  | isTcTyVar tv && isSkolemTyVar tv
-  = do { tc_lvl <- getTcLevel
-       ; zonkPromoteTyCoVarKind (promoteSkolem tc_lvl tv) }
-
-  | otherwise
-  = zonkPromoteTyCoVarKind tv
-
 zonkPromoteCoercion :: Coercion -> TcM Coercion
 zonkPromoteCoercion = mapCoercion zonkPromoteMapper ()
 
@@ -2765,7 +2560,7 @@ tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
 tcLHsKindSig ctxt hs_kind
 -- See  Note [Recipe for checking a signature] in TcHsType
 -- Result is zonked
-  = do { kind <- solveLocalEqualities $
+  = do { kind <- solveLocalEqualities "tcLHsKindSig" $
                  tc_lhs_kind kindLevelMode hs_kind
        ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)
        -- No generalization, so we must promote
@@ -2828,13 +2623,83 @@ badPatTyVarTvs sig_ty bad_tvs
 ************************************************************************
 -}
 
--- | Make an appropriate message for an error in a function argument.
--- Used for both expressions and types.
-funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc
-funAppCtxt fun arg arg_no
-  = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"),
-                    quotes (ppr fun) <> text ", namely"])
-       2 (quotes (ppr arg))
+
+{- Note [Free-floating kind vars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  data S a = MkS (Proxy (a :: k))
+
+According to the rules around implicitly-bound kind variables,
+that k scopes over the whole declaration. The renamer grabs
+it and adds it to the hsq_implicits field of the HsQTyVars of the
+tycon.  So we get
+   S :: forall {k}. k -> Type
+
+That's fine.  But consider this variant:
+  data T = MkT (forall (a :: k). Proxy a)
+  -- from test ghci/scripts/T7873
+
+This is not an existential datatype, but a higher-rank one (the forall
+to the right of MkT). Again, 'k' scopes over the whole declaration,
+but we do not want to get
+   T :: forall {k}. Type
+Why not? Because the kind variable isn't fixed by anything. For
+a variable like k to be implicit, it needs to be mentioned in the kind
+of a tycon tyvar. But it isn't.
+
+Rejecting T depends on whether or not the datatype has a CUSK.
+
+Non-CUSK (handled in TcTyClsDecls.kcTyClGroup (generalise)):
+   When generalising the TyCon we check that every Specified 'k'
+   appears free in the kind of the TyCon; that is, in the kind of
+   one of its Required arguments, or the result kind.
+
+CUSK (handled in TcHsType.kcLHsQTyVars, the CUSK case):
+   When we determine the tycon's final, never-to-be-changed kind
+   in kcLHsQTyVars, we check to make sure all implicitly-bound kind
+   vars are indeed mentioned in a kind somewhere. If not, error.
+
+We also perform free-floating kind var analysis for type family instances
+(see #13985). Here is an interesting example:
+
+    type family   T :: k
+    type instance T = (Nothing :: Maybe a)
+
+Upon a cursory glance, it may appear that the kind variable `a` is
+free-floating above, since there are no (visible) LHS patterns in `T`. However,
+there is an *invisible* pattern due to the return kind, so inside of GHC, the
+instance looks closer to this:
+
+    type family T @k :: k
+    type instance T @(Maybe a) = (Nothing :: Maybe a)
+
+Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in
+fact not free-floating. Contrast that with this example:
+
+    type instance T = Proxy (Nothing :: Maybe a)
+
+This would looks like this inside of GHC:
+
+    type instance T @(*) = Proxy (Nothing :: Maybe a)
+
+So this time, `a` is neither bound by a visible nor invisible type pattern on
+the LHS, so it would be reported as free-floating.
+
+Finally, here's one more brain-teaser (from #9574). In the example below:
+
+    class Funct f where
+      type Codomain f :: *
+    instance Funct ('KProxy :: KProxy o) where
+      type Codomain 'KProxy = NatTr (Proxy :: o -> *)
+
+As it turns out, `o` is not free-floating in this example. That is because `o`
+bound by the kind signature of the LHS type pattern 'KProxy. To make this more
+obvious, one can also write the instance like so:
+
+    instance Funct ('KProxy :: KProxy o) where
+      type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *)
+-}
 
 -- See Note [Free-floating kind vars]
 reportFloatingKvs :: Name         -- of the tycon
@@ -2865,17 +2730,27 @@ reportFloatingKvs tycon_name flav all_tvs bad_tvs
     ppr_tv_bndrs tvs = sep (map pp_tv tvs)
     pp_tv tv         = parens (ppr tv <+> dcolon <+> ppr (tyVarKind tv))
 
--- | If the inner action emits constraints, reports them as errors and fails;
+-- | If the inner action emits constraints, report them as errors and fail;
 -- otherwise, propagates the return value. Useful as a wrapper around
 -- 'tcImplicitTKBndrs', which uses solveLocalEqualities, when there won't be
 -- another chance to solve constraints
 failIfEmitsConstraints :: TcM a -> TcM a
 failIfEmitsConstraints thing_inside
-  = do { (res, lie) <- captureConstraints thing_inside
-       ; checkNoErrs $ reportAllUnsolved lie
+  = checkNoErrs $  -- We say that we fail if there are constraints!
+                   -- c.f same checkNoErrs in solveEqualities
+    do { (res, lie) <- captureConstraints thing_inside
+       ; reportAllUnsolved lie
        ; return res
        }
 
+-- | Make an appropriate message for an error in a function argument.
+-- Used for both expressions and types.
+funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc
+funAppCtxt fun arg arg_no
+  = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"),
+                    quotes (ppr fun) <> text ", namely"])
+       2 (quotes (ppr arg))
+
 -- | Add a "In the data declaration for T" or some such.
 addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a
 addTyConFlavCtxt name flav
index ba2fd75..b8eb17f 100644 (file)
@@ -31,6 +31,7 @@ import TcMType
 import TcType
 import BuildTyCl
 import Inst
+import ClsInst( AssocInstInfo(..), isNotAssociated )
 import InstEnv
 import FamInst
 import FamInstEnv
@@ -58,7 +59,6 @@ import ErrUtils
 import FastString
 import Id
 import ListSetOps
-import MkId
 import Name
 import NameSet
 import Outputable
@@ -69,6 +69,7 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
 import Maybes
+import Data.List( mapAccumL )
 
 
 {-
@@ -449,11 +450,11 @@ tcLocalInstDecl :: LInstDecl GhcRn
         --
         -- We check for respectable instance type, and context
 tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
-  = do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl)
+  = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl)
        ; return ([], [fam_inst], []) }
 
 tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
-  = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl Nothing (L loc decl)
+  = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated (L loc decl)
        ; return ([], [fam_inst], maybeToList m_deriv_info) }
 
 tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
@@ -465,69 +466,85 @@ tcLocalInstDecl (L _ (XInstDecl _)) = panic "tcLocalInstDecl"
 tcClsInstDecl :: LClsInstDecl GhcRn
               -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
 -- The returned DerivInfos are for any associated data families
-tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
+tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
                                   , cid_sigs = uprags, cid_tyfam_insts = ats
                                   , cid_overlap_mode = overlap_mode
                                   , cid_datafam_insts = adts }))
   = setSrcSpan loc                      $
-    addErrCtxt (instDeclCtxt1 poly_ty)  $
-    do  { (tyvars, theta, clas, inst_tys)
-             <- tcHsClsInstType (InstDeclCtxt False) poly_ty
+    addErrCtxt (instDeclCtxt1 hs_ty)  $
+    do  { traceTc "tcLocalInstDecl" (ppr hs_ty)
+        ; dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty
+        ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty
              -- NB: tcHsClsInstType does checkValidInstance
 
-        ; let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
-              mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
-              mb_info    = Just (clas, tyvars, mini_env)
+        ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars
+        ; let tv_skol_prs = [ (tyVarName tv, skol_tv)
+                            | (tv, skol_tv) <- tyvars `zip` skol_tvs ]
+              n_inferred = countWhile ((== Inferred) . binderArgFlag) $
+                           fst $ splitForAllVarBndrs dfun_ty
+              visible_skol_tvs = drop n_inferred skol_tvs
+
+        ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs $$ ppr visible_skol_tvs)
 
         -- Next, process any associated types.
-        ; traceTc "tcLocalInstDecl" (ppr poly_ty)
-        ; tyfam_insts0  <- scopeTyVars InstSkol tyvars $
-                           mapAndRecoverM (tcTyFamInstDecl mb_info) ats
-        ; datafam_stuff <- scopeTyVars InstSkol tyvars $
-                           mapAndRecoverM (tcDataFamInstDecl mb_info) adts
-        ; let (datafam_insts, m_deriv_infos) = unzip datafam_stuff
-              deriv_infos                    = catMaybes m_deriv_infos
+        ; (datafam_stuff, tyfam_insts)
+             <- tcExtendNameTyVarEnv tv_skol_prs $
+                do  { let mini_env   = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys)
+                          mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env
+                          mb_info    = InClsInst { ai_class = clas
+                                                 , ai_tyvars = visible_skol_tvs
+                                                 , ai_inst_env = mini_env }
+                    ; df_stuff  <- mapAndRecoverM (tcDataFamInstDecl mb_info) adts
+                    ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info)   ats
+
+                      -- Check for missing associated types and build them
+                      -- from their defaults (if available)
+                    ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats)
+                                        (classATItems clas)
+
+                    ; return (df_stuff, tf_insts1 ++ concat tf_insts2) }
 
-        -- Check for missing associated types and build them
-        -- from their defaults (if available)
-        ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
-                            `unionNameSet`
-                            mkNameSet (map (unLoc . feqn_tycon
-                                                  . hsib_body
-                                                  . dfid_eqn
-                                                  . unLoc) adts)
-        ; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats)
-                               (classATItems clas)
 
         -- Finally, construct the Core representation of the instance.
         -- (This no longer includes the associated types.)
-        ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType poly_ty))
+        ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType hs_ty))
                 -- Dfun location is that of instance *header*
 
-        ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name tyvars theta
-                              clas inst_tys
+        ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name
+                              tyvars theta clas inst_tys
+
+        ; let inst_binds = InstBindings
+                             { ib_binds = binds
+                             , ib_tyvars = map Var.varName tyvars -- Scope over bindings
+                             , ib_pragmas = uprags
+                             , ib_extensions = []
+                             , ib_derived = False }
+              inst_info = InstInfo { iSpec  = ispec, iBinds = inst_binds }
 
-        ; let inst_info = InstInfo { iSpec  = ispec
-                                   , iBinds = InstBindings
-                                     { ib_binds = binds
-                                     , ib_tyvars = map Var.varName tyvars -- Scope over bindings
-                                     , ib_pragmas = uprags
-                                     , ib_extensions = []
-                                     , ib_derived = False } }
+              (datafam_insts, m_deriv_infos) = unzip datafam_stuff
+              deriv_infos                    = catMaybes m_deriv_infos
+              all_insts                      = tyfam_insts ++ datafam_insts
 
          -- In hs-boot files there should be no bindings
         ; is_boot <- tcIsHsBootOrSig
         ; let no_binds = isEmptyLHsBinds binds && null uprags
         ; failIfTc (is_boot && not no_binds) badBootDeclErr
 
-        ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts
-                 , deriv_infos ) }
+        ; return ( [inst_info], all_insts, deriv_infos ) }
+  where
+    defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
+                  `unionNameSet`
+                  mkNameSet (map (unLoc . feqn_tycon
+                                        . hsib_body
+                                        . dfid_eqn
+                                        . unLoc) adts)
+
 tcClsInstDecl (L _ (XClsInstDecl _)) = panic "tcClsInstDecl"
 
 {-
 ************************************************************************
 *                                                                      *
-               Type checking family instances
+               Type family instances
 *                                                                      *
 ************************************************************************
 
@@ -537,37 +554,18 @@ lot of kinding and type checking code with ordinary algebraic data types (and
 GADTs).
 -}
 
-tcFamInstDeclCombined :: Maybe ClsInstInfo
-                      -> Located Name -> TcM TyCon
-tcFamInstDeclCombined mb_clsinfo fam_tc_lname
-  = do { -- Type family instances require -XTypeFamilies
-         -- and can't (currently) be in an hs-boot file
-       ; traceTc "tcFamInstDecl" (ppr fam_tc_lname)
-       ; type_families <- xoptM LangExt.TypeFamilies
-       ; is_boot <- tcIsHsBootOrSig   -- Are we compiling an hs-boot file?
-       ; checkTc type_families $ badFamInstDecl fam_tc_lname
-       ; checkTc (not is_boot) $ badBootFamInstDeclErr
-
-       -- Look up the family TyCon and check for validity including
-       -- check that toplevel type instances are not for associated types.
-       ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname
-       ; when (isNothing mb_clsinfo &&   -- Not in a class decl
-               isTyConAssoc fam_tc)      -- but an associated type
-              (addErr $ assocInClassErr fam_tc_lname)
-
-       ; return fam_tc }
-
-tcTyFamInstDecl :: Maybe ClsInstInfo
+tcTyFamInstDecl :: AssocInstInfo
                 -> LTyFamInstDecl GhcRn -> TcM FamInst
   -- "type instance"
+  -- See Note [Associated type instances]
 tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
   = setSrcSpan loc           $
     tcAddTyFamInstCtxt decl  $
     do { let fam_lname = feqn_tycon (hsib_body eqn)
-       ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname
+       ; fam_tc <- tcLookupLocatedTyCon fam_lname
+       ; tcFamInstDeclChecks mb_clsinfo fam_tc
 
          -- (0) Check it's an open type family
-       ; checkTc (isFamilyTyCon fam_tc)         (notFamily fam_tc)
        ; checkTc (isTypeFamilyTyCon fam_tc)     (wrongKindOfFamily fam_tc)
        ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)
 
@@ -575,90 +573,151 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
        ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo
                                         (L (getLoc fam_lname) eqn)
 
+
          -- (2) check for validity
-       ; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch
+       ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch
+       ; checkValidCoAxBranch fam_tc co_ax_branch
 
          -- (3) construct coercion axiom
        ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch]
        ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch
        ; newFamInst SynFamilyInst axiom }
 
-tcDataFamInstDecl :: Maybe ClsInstInfo
+
+---------------------
+tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM ()
+-- Used for both type and data families
+tcFamInstDeclChecks mb_clsinfo fam_tc
+  = do { -- Type family instances require -XTypeFamilies
+         -- and can't (currently) be in an hs-boot file
+       ; traceTc "tcFamInstDecl" (ppr fam_tc)
+       ; type_families <- xoptM LangExt.TypeFamilies
+       ; is_boot       <- tcIsHsBootOrSig   -- Are we compiling an hs-boot file?
+       ; checkTc type_families $ badFamInstDecl fam_tc
+       ; checkTc (not is_boot) $ badBootFamInstDeclErr
+
+       -- Check that it is a family TyCon, and that
+       -- oplevel type instances are not for associated types.
+       ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
+
+       ; when (isNotAssociated mb_clsinfo &&   -- Not in a class decl
+               isTyConAssoc fam_tc)            -- but an associated type
+              (addErr $ assocInClassErr fam_tc)
+       }
+
+{- Note [Associated type instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We allow this:
+  class C a where
+    type T x a
+  instance C Int where
+    type T (S y) Int = y
+    type T Z     Int = Char
+
+Note that
+  a) The variable 'x' is not bound by the class decl
+  b) 'x' is instantiated to a non-type-variable in the instance
+  c) There are several type instance decls for T in the instance
+
+All this is fine.  Of course, you can't give any *more* instances
+for (T ty Int) elsewhere, because it's an *associated* type.
+
+
+************************************************************************
+*                                                                      *
+               Data family instances
+*                                                                      *
+************************************************************************
+
+For some reason data family instances are a lot more complicated
+than type family instances
+-}
+
+tcDataFamInstDecl :: AssocInstInfo
                   -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
   -- "newtype instance" and "data instance"
 tcDataFamInstDecl mb_clsinfo
-    (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = tv_names
+    (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars
                                                    , hsib_body =
       FamEqn { feqn_bndrs  = mb_bndrs
-             , feqn_pats   = pats
-             , feqn_tycon  = fam_tc_name
+             , feqn_pats   = hs_pats
+             , feqn_tycon  = lfam_name@(L _ fam_name)
              , feqn_fixity = fixity
-             , feqn_rhs    = HsDataDefn { dd_ND = new_or_data
-                                        , dd_cType = cType
-                                        , dd_ctxt ctxt
-                                        , dd_cons cons
+             , feqn_rhs    = HsDataDefn { dd_ND      = new_or_data
+                                        , dd_cType   = cType
+                                        , dd_ctxt    = hs_ctxt
+                                        , dd_cons    = hs_cons
                                         , dd_kindSig = m_ksig
-                                        , dd_derivs = derivs } }}}))
+                                        , dd_derivs  = derivs } }}}))
   = setSrcSpan loc             $
     tcAddDataFamInstCtxt decl  $
-    do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name
-
-         -- Check that the family declaration is for the right kind
-       ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
-       ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
+    do { fam_tc <- tcLookupLocatedTyCon lfam_name
 
-         -- Kind check type patterns
-       ; let mb_kind_env = thdOf3 <$> mb_clsinfo
-       ; tcFamTyPats fam_tc mb_clsinfo tv_names mb_bndrs pats
-                     (kcDataDefn mb_kind_env decl) $
-             \tvs pats res_kind ->
-    do { stupid_theta <- solveEqualities $ tcHsContext ctxt
+       ; tcFamInstDeclChecks mb_clsinfo fam_tc
 
-            -- Zonk the patterns etc into the Type world
-       ; (ze, tvs')    <- zonkTyBndrs tvs
-       ; pats'         <- zonkTcTypesToTypesX ze pats
-       ; res_kind'     <- zonkTcTypeToTypeX   ze res_kind
-       ; stupid_theta' <- zonkTcTypesToTypesX ze stupid_theta
-
-       ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta' cons
-
-         -- Construct representation tycon
-       ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
-       ; axiom_name  <- newFamInstAxiomName fam_tc_name [pats']
-
-       ; let (eta_pats, etad_tvs) = eta_reduce pats'
-             eta_tvs              = filterOut (`elem` etad_tvs) tvs'
-                 -- NB: the "extra" tvs from tcDataKindSig would always be eta-reduced
-
-             full_tcbs = mkTyConBindersPreferAnon (eta_tvs ++ etad_tvs) res_kind'
+       -- Check that the family declaration is for the right kind
+       ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
+       ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons
+          -- Do /not/ check that the number of patterns = tyConArity fam_tc
+          -- See [Arity of data families] in FamInstEnv
+
+       ; (qtvs, pats, res_kind, stupid_theta)
+             <- tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs
+                                fixity hs_ctxt hs_pats m_ksig hs_cons
+
+       -- Eta-reduce the axiom if possible
+       -- Quite tricky: see Note [Eta-reduction for data families]
+       ; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats
+             eta_tvs       = map binderVar eta_tcbs
+             post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs
+
+             full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs
+                            (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind))
+                         ++ eta_tcbs
                  -- Put the eta-removed tyvars at the end
-                 -- Remember, tvs' is in arbitrary order (except kind vars are
-                 -- first, so there is no reason to suppose that the etad_tvs
+                 -- Remember, qtvs is in arbitrary order, except kind vars are
+                 -- first, so there is no reason to suppose that the eta_tvs
                  -- (obtained from the pats) are at the end (Trac #11148)
 
-         -- Deal with any kind signature.
-         -- See also Note [Arity of data families] in FamInstEnv
-       ; (extra_tcbs, final_res_kind) <- tcDataKindSig full_tcbs res_kind'
-       ; checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind')
-
+       -- Eta-expand the representation tycon until it has reult kind *
+       -- See also Note [Arity of data families] in FamInstEnv
+       -- NB: we can do this after eta-reducing the axiom, because if
+       --     we did it before the "extra" tvs from etaExpandAlgTyCon
+       --     would always be eta-reduced
+       ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind
+       ; checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind)
        ; let extra_pats  = map (mkTyVarTy . binderVar) extra_tcbs
-             all_pats    = pats' `chkAppend` extra_pats
+             all_pats    = pats `chkAppend` extra_pats
              orig_res_ty = mkTyConApp fam_tc all_pats
+             ty_binders  = full_tcbs `chkAppend` extra_tcbs
+
+       ; traceTc "tcDataFamInstDecl" $
+         vcat [ text "Fam tycon:" <+> ppr fam_tc
+              , text "Pats:" <+> ppr pats
+              , text "visibliities:" <+> ppr (tcbVisibilities fam_tc pats)
+              , text "all_pats:" <+> ppr all_pats
+              , text "ty_binders" <+> ppr ty_binders
+              , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)
+              , text "eta_pats" <+> ppr eta_pats
+              , text "eta_tcbs" <+> ppr eta_tcbs ]
 
        ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->
-           do { let ty_binders = full_tcbs `chkAppend` extra_tcbs
-              ; data_cons <- tcConDecls rec_rep_tc
-                                        ty_binders orig_res_ty cons
+           do { data_cons <- tcExtendTyVarEnv qtvs $
+                             -- For H98 decls, the tyvars scope
+                             -- over the data constructors
+                             tcConDecls rec_rep_tc ty_binders orig_res_ty hs_cons
+
+              ; rep_tc_name <- newFamInstTyConName lfam_name pats
+              ; axiom_name  <- newFamInstAxiomName lfam_name [pats]
               ; tc_rhs <- case new_or_data of
                      DataType -> return (mkDataTyConRhs data_cons)
                      NewType  -> ASSERT( not (null data_cons) )
                                  mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
-              -- freshen tyvars
-              ; let axiom  = mkSingleCoAxiom Representational
-                                             axiom_name eta_tvs [] fam_tc eta_pats
-                                             (mkTyConApp rep_tc (mkTyVarTys eta_tvs))
-                    parent = DataFamInstTyCon axiom fam_tc all_pats
 
+              ; let axiom  = mkSingleCoAxiom Representational axiom_name
+                                 post_eta_qtvs eta_tvs [] fam_tc eta_pats
+                                 (mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs))
+                    parent = DataFamInstTyCon axiom fam_tc all_pats
 
                       -- NB: Use the full ty_binders from the pats. See bullet toward
                       -- the end of Note [Data type families] in TyCon
@@ -675,15 +734,12 @@ tcDataFamInstDecl mb_clsinfo
                  -- they involve a coercion.
               ; return (rep_tc, axiom) }
 
-         -- Remember to check validity; no recursion to worry about here
-         -- Check that left-hand sides are ok (mono-types, no type families,
-         -- consistent instantiations, etc)
-       ; checkValidFamPats mb_clsinfo fam_tc tvs' [] pats' extra_pats pp_hs_pats
-
-         -- Result kind must be '*' (otherwise, we have too few patterns)
-       ; checkTc (tcIsLiftedTypeKind final_res_kind) $
-         tooFewParmsErr (tyConArity fam_tc)
-
+       -- Remember to check validity; no recursion to worry about here
+       -- Check that left-hand sides are ok (mono-types, no type families,
+       -- consistent instantiations, etc)
+       ; let ax_branch = coAxiomSingleBranch axiom
+       ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch
+       ; checkValidCoAxBranch fam_tc ax_branch
        ; checkValidTyCon rep_tc
 
        ; let m_deriv_info = case derivs of
@@ -694,38 +750,182 @@ tcDataFamInstDecl mb_clsinfo
                                   , di_ctxt    = tcMkDataFamInstCtxt decl }
 
        ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
-       ; return (fam_inst, m_deriv_info) } }
+       ; return (fam_inst, m_deriv_info) }
   where
-    eta_reduce :: [Type] -> ([Type], [TyVar])
+    eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder])
     -- See Note [Eta reduction for data families] in FamInstEnv
     -- Splits the incoming patterns into two: the [TyVar]
     -- are the patterns that can be eta-reduced away.
     -- e.g.     T [a] Int a d c   ==>  (T [a] Int a, [d,c])
     --
     -- NB: quadratic algorithm, but types are small here
-    eta_reduce pats
-      = go (reverse pats) []
-    go (pat:pats) etad_tvs
+    eta_reduce fam_tc pats
+        = go (reverse (zip3 pats fvs_s vis_s)) []
+        where
+          vis_s :: [TyConBndrVis]
+          vis_s = tcbVisibilities fam_tc pats
+
+          fvs_s :: [TyCoVarSet]  -- 1-1 correspondence with pats
+                                 -- Each elt is the free vars of all /earlier/ pats
+          (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats
+          add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs)
+
+    go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs
       | Just tv <- getTyVar_maybe pat
-      , not (tv `elemVarSet` tyCoVarsOfTypes pats)
-      = go pats (tv : etad_tvs)
-    go pats etad_tvs = (reverse pats, etad_tvs)
+      , not (tv `elemVarSet` fvs_to_the_left)
+      = go pats (Bndr tv tcb_vis : etad_tvs)
+    go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs)
+
+tcDataFamInstDecl _ _ = panic "tcDataFamInstDecl"
+
+-----------------------
+tcDataFamHeader :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn]
+                -> LexicalFixity -> LHsContext GhcRn
+                -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn]
+                -> TcM ([TyVar], [Type], Kind, ThetaType)
+-- The "header" is the part other than the data constructors themselves
+-- e.g.  data instance D [a] :: * -> * = ...
+-- Here the "header" is the bit before the "=" sign
+tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksig hs_cons
+  = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, res_kind)))
+            <- pushTcLevelM_                                $
+               solveEqualities                              $
+               bindImplicitTKBndrs_Q_Skol imp_vars          $
+               bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
+               do { stupid_theta <- tcHsContext hs_ctxt
+                  ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc mb_clsinfo hs_pats
+                  ; mapM_ (wrapLocM_ kcConDecl) hs_cons
+                  ; res_kind <- tc_kind_sig m_ksig
+                  ; lhs_ty <- checkExpectedKindX pp_lhs lhs_ty lhs_kind res_kind
+                  ; return (stupid_theta, lhs_ty, res_kind) }
+
+       -- See Note [Generalising in tcFamTyPatsAndThen]
+       ; let scoped_tvs = imp_tvs ++ exp_tvs
+       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)
+       ; qtvs <- quantifyTyVars emptyVarSet dvs
+
+       -- Zonk the patterns etc into the Type world
+       ; (ze, qtvs)   <- zonkTyBndrs qtvs
+       ; lhs_ty       <- zonkTcTypeToTypeX ze lhs_ty
+       ; res_kind     <- zonkTcTypeToTypeX ze res_kind
+       ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta
+
+       -- Check that type patterns match the class instance head
+       ; let pats = unravelFamInstPats lhs_ty
+       ; return (qtvs, pats, res_kind, stupid_theta) }
+  where
+    fam_name  = tyConName fam_tc
+    data_ctxt = DataKindCtxt fam_name
+    pp_lhs    = pprHsFamInstLHS fam_name mb_bndrs hs_pats fixity hs_ctxt
+    exp_bndrs = mb_bndrs `orElse` []
+
+    -- See Note [Result kind signature for a data family instance]
+    tc_kind_sig Nothing
+      = return liftedTypeKind
+    tc_kind_sig (Just hs_kind)
+      = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind
+           ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind
+           ; lvl <- getTcLevel
+           ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs
+             -- Perhaps surprisingly, we don't need the skolemised tvs themselves
+           ; return (substTy subst inner_kind) }
+
+{- Note [Result kind signature for a data family instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The expected type might have a forall at the type. Normally, we
+can't skolemise in kinds because we don't have type-level lambda.
+But here, we're at the top-level of an instance declaration, so
+we actually have a place to put the regeneralised variables.
+Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise
+Examples in indexed-types/should_compile/T12369
+
+Note [Eta-reduction for data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   data D :: * -> * -> * -> * -> *
+
+   data instance D [(a,b)] p q :: * -> * where
+      D1 :: blah1
+      D2 :: blah2
 
-    pp_hs_pats = pprFamInstLHS fam_tc_name mb_bndrs pats fixity (unLoc ctxt) m_ksig
+Then we'll generate a representation data type
+  data Drep a b p q z where
+      D1 :: blah1
+      D2 :: blah2
 
-tcDataFamInstDecl _
-    (L _ (DataFamInstDecl
-         { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = XHsDataDefn _ }}}))
-  = panic "tcDataFamInstDecl"
-tcDataFamInstDecl _ (L _ (DataFamInstDecl (XHsImplicitBndrs _)))
-  = panic "tcDataFamInstDecl"
-tcDataFamInstDecl _ (L _ (DataFamInstDecl (HsIB _ (XFamEqn _))))
-  = panic "tcDataFamInstDecl"
+and an axiom to connect them
+  axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z
+
+except that we'll eta-reduce the axiom to
+  axiom AxDrep forall a b. D [(a,b]] = Drep a b
+There are several fiddly subtleties lurking here
+
+* The representation tycon Drep is parameerised over the free
+  variables of the pattern, in no particular order. So there is no
+  guarantee that 'p' and 'q' will come last in Drep's parameters, and
+  in the right order.  So, if the /patterns/ of the family insatance
+  are eta-redcible, we re-order Drep's parameters to put the
+  eta-reduced type variables last.
+
+* Although we eta-reduce the axiom, we eta-/expand/ the representation
+  tycon Drep.  The kind of D says it takses four arguments, but the
+  data instance header only supplies three.  But the AlgTyCOn for Drep
+  itself must have enough TyConBinders so that its result kind is Type.
+  So, with etaExpandAlgTyCon we make up some extra TyConBinders
+
+* The result kind in the instance might be a polykind, like this:
+     data family DP a :: forall k. k -> *
+     data instance DP [b] :: forall k1 k2. (k1,k2) -> *
+
+  So in type-checking the LHS (DP Int) we need to check that it is
+  more polymorphic than the signature.  To do that we must skolemise
+  the siganture and istantiate the call of DP.  So we end up with
+     data instance DP [b] @(k1,k2) (z :: (k1,k2)) where
+
+  Note that we must parameterise the representation tycon DPrep over
+  'k1' and 'k2', as well as 'b'.
+
+  The skolemise bit is done in tc_kind_sig, while the instantiate bit
+  is done by the checkExpectedKind that immediately follows.
+
+* Very fiddly point.  When we eta-reduce to
+     axiom AxDrep forall a b. D [(a,b]] = Drep a b
+
+  we want the kind of (D [(a,b)]) to be the same as the kind of
+  (Drep a b).  This ensures that applying the axiom doesn't change the
+  kind.  Why is that hard?  Because the kind of (Drep a b) depends on
+  the TyConBndrVis on Drep's arguments. In particular do we have
+    (forall (k::*). blah) or (* -> blah)?
+
+  We must match whatever D does!  In Trac #15817 we had
+      data family X a :: forall k. * -> *   -- Note: a forall that is not used
+      data instance X Int b = MkX
+
+  So the data intance is really
+      data istance X Int @k b = MkX
+
+  The axiom will look like
+      axiom    X Int = Xrep
+
+  and it's important that XRep :: forall k * -> *, following X.
+
+  To achieve this we get the TyConBndrVis flags from tcbVisibilities,
+  and use those flags for any eta-reduced arguments.  Sigh.
+
+* The final turn of the knife is that tcbVisibilities is itself
+  tricky to sort out.  Consider
+      data family D k :: k
+  Then consider D (forall k2. k2 -> k2) Type Type
+  The visibilty flags on an application of D may affected by the arguments
+  themselves.  Heavy sigh.  But not truly hard; that's what tcbVisibilities
+  does.
+
+-}
 
 
 {- *********************************************************************
 *                                                                      *
-      Type-checking instance declarations, pass 2
+      Class instance declarations, pass 2
 *                                                                      *
 ********************************************************************* -}
 
@@ -794,7 +994,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
          -- See Note [Typechecking plan for instance declarations]
        ; dfun_ev_binds_var <- newTcEvBinds
        ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var
-       ; ((sc_meth_ids, sc_meth_binds, sc_meth_implics), tclvl)
+       ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics))
              <- pushTcLevelM $
                 do { (sc_ids, sc_binds, sc_implics)
                         <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars
@@ -1253,8 +1453,6 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                                 , ib_pragmas    = sigs
                                 , ib_extensions = exts
                                 , ib_derived    = is_derived })
-      -- tcExtendTyVarEnv (not scopeTyVars) is OK because the TcLevel is pushed
-      -- in checkInstConstraints
   = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $
        -- The lexical_tvs scope over the 'where' part
     do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
@@ -1872,8 +2070,7 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
 tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
 tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty)
   = addErrCtxt (spec_ctxt prag) $
-    do  { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty
-        ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
+    do  { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty
         ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
         ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
   where
@@ -1912,17 +2109,12 @@ notFamily tycon
   = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)
          , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")]
 
-tooFewParmsErr :: Arity -> SDoc
-tooFewParmsErr arity
-  = text "Family instance has too few parameters; expected" <+>
-    ppr arity
-
-assocInClassErr :: Located Name -> SDoc
+assocInClassErr :: TyCon -> SDoc
 assocInClassErr name
  = text "Associated type" <+> quotes (ppr name) <+>
    text "must be inside a class instance"
 
-badFamInstDecl :: Located Name -> SDoc
+badFamInstDecl :: TyCon -> SDoc
 badFamInstDecl tc_name
   = vcat [ text "Illegal family instance for" <+>
            quotes (ppr tc_name)
index c3786e2..3500b72 100644 (file)
@@ -41,6 +41,7 @@ module TcMType (
   newEvVar, newEvVars, newDict,
   newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC,
   emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,
+  emitDerivedEqs,
   newTcEvBinds, newNoTcEvBinds, addTcEvBind,
 
   newCoercionHole, fillCoercionHole, isFilledCoercionHole,
@@ -53,11 +54,10 @@ module TcMType (
   newMetaTyVarTyVars, newMetaTyVarTyVarX,
   newTyVarTyVar, newTauTyVar, newSkolemTyVar, newWildCardX,
   tcInstType,
-  tcInstSkolTyVars,tcInstSkolTyVarsX,
-  tcInstSuperSkolTyVarsX,
-  tcSkolDFunType, tcSuperSkolTyVars,
+  tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,
+  tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,
 
-  instSkolTyCoVarsX, freshenTyVarBndrs, freshenCoVarBndrsX,
+  freshenTyVarBndrs, freshenCoVarBndrsX,
 
   --------------------------------
   -- Zonking and tidying
@@ -67,9 +67,10 @@ module TcMType (
   zonkTcTyVarToTyVar, zonkTyVarTyVarPairs,
   zonkTyCoVarsAndFV, zonkTcTypeAndFV,
   zonkTyCoVarsAndFVList,
-  candidateQTyVarsOfType, candidateQTyVarsOfKind,
-  candidateQTyVarsOfTypes, CandidatesQTvs(..),
-  zonkQuantifiedTyVar, defaultTyVar,
+  candidateQTyVarsOfType,  candidateQTyVarsOfKind,
+  candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,
+  CandidatesQTvs(..), delCandidates, candidateKindVars,
+  skolemiseQuantifiedTyVar, defaultTyVar,
   quantifyTyVars,
   zonkTcTyCoVarBndr, zonkTyConBinders,
   zonkTcType, zonkTcTypes, zonkCo,
@@ -113,7 +114,6 @@ import PrelNames
 import Util
 import Outputable
 import FastString
-import SrcLoc
 import Bag
 import Pair
 import UniqSet
@@ -121,7 +121,7 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
 import Maybes
-import Data.List        ( mapAccumL, partition )
+import Data.List        ( mapAccumL )
 import Control.Arrow    ( second )
 import qualified Data.Semigroup as Semi
 
@@ -232,6 +232,20 @@ emitWanted origin pty
        ; emitSimple $ mkNonCanonical ev
        ; return $ ctEvTerm ev }
 
+emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()
+-- Emit some new derived nominal equalities
+emitDerivedEqs origin pairs
+  | null pairs
+  = return ()
+  | otherwise
+  = do { loc <- getCtLocM origin Nothing
+       ; emitSimples (listToBag (map (mk_one loc) pairs)) }
+  where
+    mk_one loc (ty1, ty2)
+       = mkNonCanonical $
+         CtDerived { ctev_pred = mkPrimEqPred ty1 ty2
+                   , ctev_loc = loc }
+
 -- | Emits a new equality constraint
 emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion
 emitWantedEq origin t_or_k role ty1 ty2
@@ -507,108 +521,101 @@ tcSuperSkolTyVar subst tv
 
 -- | Given a list of @['TyVar']@, skolemize the type variables,
 -- returning a substitution mapping the original tyvars to the
--- skolems, and the list of newly bound skolems.  See also
--- tcInstSkolTyVars' for a precondition.  The resulting
--- skolems are non-overlappable; see Note [Overlap and deriving]
--- for an example where this matters.
+-- skolems, and the list of newly bound skolems.
 tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
 tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst
 
 tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
-tcInstSkolTyVarsX = tcInstSkolTyVars' False
+-- See Note [Skolemising type variables]
+tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False
 
 tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
 tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst
 
 tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
-tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst
-
-tcInstSkolTyVars' :: Bool -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
--- Precondition: tyvars should be ordered (kind vars first)
--- see Note [Kind substitution when instantiating]
--- Get the location from the monad; this is a complete freshening operation
-tcInstSkolTyVars' overlappable subst tvs
-  = do { loc <- getSrcSpanM
-       ; lvl <- getTcLevel
-       ; instSkolTyCoVarsX (mkTcSkolTyVar lvl loc overlappable) subst tvs }
-
-mkTcSkolTyVar :: TcLevel -> SrcSpan -> Bool -> TcTyCoVarMaker gbl lcl
--- Allocates skolems whose level is ONE GREATER THAN the passed-in tc_lvl
--- See Note [Skolem level allocation]
-mkTcSkolTyVar tc_lvl loc overlappable old_name kind
-  = do { uniq <- newUnique
-       ; let name = mkInternalName uniq (getOccName old_name) loc
-       ; return (mkTcTyVar name kind details) }
+-- See Note [Skolemising type variables]
+tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst
+
+tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar]
+                          -> TcM (TCvSubst, [TcTyVar])
+-- Skolemise one level deeper, hence pushTcLevel
+-- See Note [Skolemising type variables]
+tcInstSkolTyVarsPushLevel overlappable subst tvs
+  = do { tc_lvl <- getTcLevel
+       ; let pushed_lvl = pushTcLevel tc_lvl
+       ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs }
+
+tcInstSkolTyVarsAt :: TcLevel -> Bool
+                   -> TCvSubst -> [TyVar]
+                   -> TcM (TCvSubst, [TcTyVar])
+tcInstSkolTyVarsAt lvl overlappable subst tvs
+  = freshenTyCoVarsX new_skol_tv subst tvs
   where
-    details = SkolemTv (pushTcLevel tc_lvl) overlappable
-              -- pushTcLevel: see Note [Skolem level allocation]
-
-{- Note [Skolem level allocation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We generally allocate skolems /before/ calling pushLevelAndCaptureConstraints.
-So we want their level to the level of the soon-to-be-created implication,
-which has a level one higher than the current level.  Hence the pushTcLevel.
-It feels like a slight hack.  Applies also to vanillaSkolemTv.
-
--}
+    details = SkolemTv lvl overlappable
+    new_skol_tv name kind = mkTcTyVar name kind details
 
 ------------------
-freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyVar])
+freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar])
 -- ^ Give fresh uniques to a bunch of TyVars, but they stay
 --   as TyVars, rather than becoming TcTyVars
 -- Used in FamInst.newFamInst, and Inst.newClsInst
-freshenTyVarBndrs = instSkolTyCoVars mk_tv
-  where
-    mk_tv old_name kind
-       = do { uniq <- newUnique
-            ; return (mkTyVar (setNameUnique old_name uniq) kind) }
+freshenTyVarBndrs = freshenTyCoVars mkTyVar
 
-freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcRnIf gbl lcl (TCvSubst, [CoVar])
+freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar])
 -- ^ Give fresh uniques to a bunch of CoVars
 -- Used in FamInst.newFamInst
-freshenCoVarBndrsX subst = instSkolTyCoVarsX mk_cv subst
-  where
-    mk_cv old_name kind
-      = do { uniq <- newUnique
-           ; return (mkCoVar (setNameUnique old_name uniq) kind) }
+freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst
 
 ------------------
-type TcTyCoVarMaker gbl lcl = Name -> Kind -> TcRnIf gbl lcl TyCoVar
-     -- The TcTyCoVarMaker should make a fresh Name, based on the old one
-     -- Freshness is critical. See Note [Skolems in zonkSyntaxExpr] in TcHsSyn
-
-instSkolTyCoVars :: TcTyCoVarMaker gbl lcl -> [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar])
-instSkolTyCoVars mk_tcv = instSkolTyCoVarsX mk_tcv emptyTCvSubst
-
-instSkolTyCoVarsX :: TcTyCoVarMaker gbl lcl
-                  -> TCvSubst -> [TyCoVar] -> TcRnIf gbl lcl (TCvSubst, [TyCoVar])
-instSkolTyCoVarsX mk_tcv = mapAccumLM (instSkolTyCoVarX mk_tcv)
-
-instSkolTyCoVarX :: TcTyCoVarMaker gbl lcl
-                 -> TCvSubst -> TyCoVar -> TcRnIf gbl lcl (TCvSubst, TyCoVar)
-instSkolTyCoVarX mk_tcv subst tycovar
-  = do  { new_tcv <- mk_tcv old_name kind
-        ; let subst1 | isTyVar new_tcv
-                     = extendTvSubstWithClone subst tycovar new_tcv
-                     | otherwise
-                     = extendCvSubstWithClone subst tycovar new_tcv
-        ; return (subst1, new_tcv) }
-  where
-    old_name = tyVarName tycovar
-    kind     = substTyUnchecked subst (tyVarKind tycovar)
+freshenTyCoVars :: (Name -> Kind -> TyCoVar)
+                -> [TyVar] -> TcM (TCvSubst, [TyCoVar])
+freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst
+
+freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)
+                 -> TCvSubst -> [TyCoVar]
+                 -> TcM (TCvSubst, [TyCoVar])
+freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv)
+
+freshenTyCoVarX :: (Name -> Kind -> TyCoVar)
+                -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar)
+-- This a complete freshening operation:
+-- the skolems have a fresh unique, and a location from the monad
+-- See Note [Skolemising type variables]
+freshenTyCoVarX mk_tcv subst tycovar
+  = do { loc  <- getSrcSpanM
+       ; uniq <- newUnique
+       ; let old_name = tyVarName tycovar
+             new_name = mkInternalName uniq (getOccName old_name) loc
+             new_kind = substTyUnchecked subst (tyVarKind tycovar)
+             new_tcv  = mk_tcv new_name new_kind
+             subst1   = extendTCvSubstWithClone subst tycovar new_tcv
+       ; return (subst1, new_tcv) }
+
+{- Note [Skolemising type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The tcInstSkolTyVars family of functions instantiate a list of TyVars
+to fresh skolem TcTyVars. Important notes:
+
+a) Level allocation. We generally skolemise /before/ calling
+   pushLevelAndCaptureConstraints.  So we want their level to the level
+   of the soon-to-be-created implication, which has a level ONE HIGHER
+   than the current level.  Hence the pushTcLevel.  It feels like a
+   slight hack.
+
+b) The [TyVar] should be ordered (kind vars first)
+   See Note [Kind substitution when instantiating]
+
+c) It's a complete freshening operation: the skolems have a fresh
+   unique, and a location from the monad
+
+d) The resulting skolems are
+        non-overlappable for tcInstSkolTyVars,
+   but overlappable for tcInstSuperSkolTyVars
+   See TcDerivInfer Note [Overlap and deriving] for an example
+   of where this matters.
 
-newFskTyVar :: TcType -> TcM TcTyVar
-newFskTyVar fam_ty
-  = do { uniq <- newUnique
-       ; ref  <- newMutVar Flexi
-       ; tclvl <- getTcLevel
-       ; let details = MetaTv { mtv_info  = FlatSkolTv
-                              , mtv_ref   = ref
-                              , mtv_tclvl = tclvl }
-             name = mkMetaTyVarName uniq (fsLit "fsk")
-       ; return (mkTcTyVar name (typeKind fam_ty) details) }
-
-{-
 Note [Kind substitution when instantiating]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we instantiate a bunch of kind and type variables, first we
@@ -648,9 +655,10 @@ but this restriction was dropped, and ScopedTypeVariables can now refer to full
 types (GHC Proposal 29).
 
 The remaining uses of newTyVarTyVars are
-* in kind signatures, see Note [Kind generalisation and TyVarTvs]
-  and Note [Use TyVarTvs in kind-checking pass]
-* in partial type signatures, see Note [Quantified variables in partial type signatures]
+* In kind signatures, see
+  TcTyClsDecls Note [Inferring kinds for type declarations]
+           and Note [Kind checking for GADTs]
+* In partial type signatures, see Note [Quantified variables in partial type signatures]
 -}
 
 -- see Note [TyVarTv]
@@ -667,6 +675,17 @@ newSkolemTyVar :: Name -> Kind -> TcM TcTyVar
 newSkolemTyVar name kind = do { lvl <- getTcLevel
                               ; return (mkTcTyVar name kind (SkolemTv lvl False)) }
 
+newFskTyVar :: TcType -> TcM TcTyVar
+newFskTyVar fam_ty
+  = do { uniq <- newUnique
+       ; ref  <- newMutVar Flexi
+       ; tclvl <- getTcLevel
+       ; let details = MetaTv { mtv_info  = FlatSkolTv
+                              , mtv_ref   = ref
+                              , mtv_tclvl = tclvl }
+             name = mkMetaTyVarName uniq (fsLit "fsk")
+       ; return (mkTcTyVar name (typeKind fam_ty) details) }
+
 newFmvTyVar :: TcType -> TcM TcTyVar
 -- Very like newMetaTyVar, except sets mtv_tclvl to one less
 -- so that the fmv is untouchable.
@@ -910,27 +929,27 @@ newOpenFlexiTyVarTy
   = do { kind <- newOpenTypeKind
        ; newFlexiTyVarTy kind }
 
-newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
-newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst
-
 newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
 -- Instantiate with META type variables
 -- Note that this works for a sequence of kind, type, and coercion variables
 -- variables.  Eg    [ (k:*), (a:k->k) ]
 --             Gives [ (k7:*), (a8:k7->k7) ]
-newMetaTyVars = mapAccumLM newMetaTyVarX emptyTCvSubst
+newMetaTyVars = newMetaTyVarsX emptyTCvSubst
     -- emptyTCvSubst has an empty in-scope set, but that's fine here
     -- Since the tyvars are freshly made, they cannot possibly be
     -- captured by any existing for-alls.
 
+newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- Just like newMetaTyVars, but start with an existing substitution.
+newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst
+
 newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
 -- Make a new unification variable tyvar whose Name and Kind come from
 -- an existing TyVar. We substitute kind variables in the kind.
 newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar
 
-newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
--- Just like newMetaTyVars, but start with an existing substitution.
-newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst
+newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst
 
 newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
 -- Just like newMetaTyVarX, but make a TyVarTv
@@ -1006,13 +1025,9 @@ instance Outputable CandidatesQTvs where
                                              , text "dv_tvs =" <+> ppr tvs
                                              , text "dv_cvs =" <+> ppr cvs ])
 
-closeOverKindsCQTvs :: TyCoVarSet  -- globals
-                    -> CandidatesQTvs -> TcM CandidatesQTvs
--- Don't close the covars; this is done in quantifyTyVars. Note that
--- closing over the CoVars would introduce tyvars into the CoVarSet.
-closeOverKindsCQTvs gbl_tvs dv@(DV { dv_kvs = kvs, dv_tvs = tvs })
-  = do { let all_kinds = map tyVarKind (dVarSetElems (kvs `unionDVarSet` tvs))
-       ; foldlM (collect_cand_qtvs True gbl_tvs) dv all_kinds }
+
+candidateKindVars :: CandidatesQTvs -> TyVarSet
+candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs)
 
 {- Note [Dependent type variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1081,40 +1096,43 @@ Note [CandidatesQTvs determinism and order]
 
 Note [Naughty quantification candidates]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#14880, dependent/should_compile/T14880-2)
+Consider (#14880, dependent/should_compile/T14880-2), suppose
+we are trying to generalise this type:
 
   forall arg. ... (alpha[tau]:arg) ...
 
-We have a metavariable alpha whose kind is a locally bound (skolem) variable.
+We have a metavariable alpha whose kind mentions a skolem variable
+boudn inside the very type we are generalising.
 This can arise while type-checking a user-written type signature
-(see the test case for the full code). According to
-Note [Recipe for checking a signature] in TcHsType, we try to solve
-all constraints that arise during checking before looking to kind-generalize.
-However, in the case above, this solving pass does not unify alpha, because
-it is utterly unconstrained. The question is: what to do with alpha?
-
-We can't generalize it, because it would have to be generalized *after*
-arg, and implicit generalization always goes before explicit generalization.
-We can't simply leave it be, because this type is about to go into the
-typing environment (as the type of some let-bound variable, say), and then
-chaos erupts when we try to instantiate. In any case, we'll never learn
-anything more about alpha anyway.
+(see the test case for the full code).
+
+We cannot generalise over alpha!  That would produce a type like
+  forall {a :: arg}. forall arg. ...blah...
+The fact that alpha's kind mentions arg renders it completely
+ineligible for generaliation.
+
+However, we are not going to learn any new constraints on alpha,
+because its kind isn't even in scope in the outer context.  So alpha
+is entirely unconstrained.
+
+What then should we do with alpha?  During generalization, every
+metavariable is either (A) promoted, (B) generalized, or (C) zapped
+(according again to Note [Recipe for checking a signature] in
+TcHsType).
+
+ * We can't generalise it.
+ * We can't promote it, because its kind prevents that
+ * We can't simply leave it be, because this type is about to
+   go into the typing environment (as the type of some let-bound
+   variable, say), and then chaos erupts when we try to instantiate.
 
 So, we zap it, eagerly, to Any. We don't have to do this eager zapping
 in terms (say, in `length []`) because terms are never re-examined before
 the final zonk (which zaps any lingering metavariables to Any).
 
-The right time to do this eager zapping is during generalization, when
-every metavariable is either (A) promoted, (B) generalized, or (C) zapped
-(according again to Note [Recipe for checking a signature] in TcHsType).
-
-Accordingly, when quantifyTyVars is skolemizing the variables to quantify,
-these naughty ones are zapped to Any. We identify the naughty ones by
-looking for out-of-scope tyvars in the candidate tyvars' kinds, where
-we assume that all in-scope tyvars are in the gbl_tvs passed to quantifyTyVars.
-In the example above, we would have `alpha` in the CandidatesQTvs, but
-`arg` wouldn't be in the gbl_tvs. Hence, alpha is naughty, and zapped to
-Any. Naughty variables are discovered by is_naughty_tv in quantifyTyVars.
+We do this eager zapping in candidateQTyVars, which always precedes
+generalisation, because at that moment we have a clear picture of
+what skolems are in scope.
 
 -}
 
@@ -1123,21 +1141,31 @@ Any. Naughty variables are discovered by is_naughty_tv in quantifyTyVars.
 -- in both sets, if it's used in both a type and a kind.
 -- See Note [CandidatesQTvs determinism and order]
 -- See Note [Dependent type variables]
-candidateQTyVarsOfType :: TcTyVarSet   -- zonked set of global/mono tyvars
-                       -> TcType       -- not necessarily zonked
+candidateQTyVarsOfType :: TcType       -- not necessarily zonked
                        -> TcM CandidatesQTvs
-candidateQTyVarsOfType gbl_tvs ty = closeOverKindsCQTvs gbl_tvs =<<
-                                    collect_cand_qtvs False gbl_tvs mempty ty
+candidateQTyVarsOfType ty = collect_cand_qtvs False emptyVarSet mempty ty
+
+-- | Like 'splitDepVarsOfType', but over a list of types
+candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs
+candidateQTyVarsOfTypes tys = foldlM (collect_cand_qtvs False emptyVarSet) mempty tys
 
 -- | Like 'candidateQTyVarsOfType', but consider every free variable
 -- to be dependent. This is appropriate when generalizing a *kind*,
 -- instead of a type. (That way, -XNoPolyKinds will default the variables
 -- to Type.)
-candidateQTyVarsOfKind :: TcTyVarSet   -- zonked set of global/mono tyvars
-                       -> TcKind       -- not necessarily zonked
+candidateQTyVarsOfKind :: TcKind       -- not necessarily zonked
+                       -> TcM CandidatesQTvs
+candidateQTyVarsOfKind ty = collect_cand_qtvs True emptyVarSet mempty ty
+
+candidateQTyVarsOfKinds :: [TcKind]       -- not necessarily zonked
                        -> TcM CandidatesQTvs
-candidateQTyVarsOfKind gbl_tvs ty = closeOverKindsCQTvs gbl_tvs =<<
-                                    collect_cand_qtvs True gbl_tvs mempty ty
+candidateQTyVarsOfKinds tys = foldM (collect_cand_qtvs True emptyVarSet) mempty tys
+
+delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs
+delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars
+  = DV { dv_kvs = kvs `delDVarSetList` vars
+       , dv_tvs = tvs `delDVarSetList` vars
+       , dv_cvs = cvs `delVarSetList`  vars }
 
 collect_cand_qtvs :: Bool   -- True <=> consider every fv in Type to be dependent
                   -> VarSet -- bound variables (both locally bound and globally bound)
@@ -1145,6 +1173,11 @@ collect_cand_qtvs :: Bool   -- True <=> consider every fv in Type to be dependen
 collect_cand_qtvs is_dep bound dvs ty
   = go dvs ty
   where
+    is_bound tv = tv `elemVarSet` bound
+
+    -----------------
+    go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs
+    -- Uses accumulating-parameter style
     go dv (AppTy t1 t2)    = foldlM go dv [t1, t2]
     go dv (TyConApp _ tys) = foldlM go dv tys
     go dv (FunTy arg res)  = foldlM go dv [arg, res]
@@ -1154,50 +1187,50 @@ collect_cand_qtvs is_dep bound dvs ty
     go dv (CoercionTy co)  = collect_cand_qtvs_co bound dv co
 
     go dv (TyVarTy tv)
-      | is_bound tv
-      = return dv
-
-      | isImmutableTyVar tv
-      = WARN(True, (sep [ text "Note [Naughty quantification candidates] skolem:"
-                        , ppr tv <+> dcolon <+> ppr (tyVarKind tv) ]))
-        return dv  -- This happens when processing kinds of variables affected by
-                   -- Note [Naughty quantification candidates]
-                   -- NB: CandidatesQTvs stores only MetaTvs, so don't store an
-                   -- immutable tyvar here.
-
-      | otherwise
-      = ASSERT2( isMetaTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) $$ ppr ty $$ ppr bound )
-        do { m_contents <- isFilledMetaTyVar_maybe tv
-           ; case m_contents of
-               Just ind_ty -> go dv ind_ty
-
-               Nothing -> return $ insert_tv dv tv }
+      | is_bound tv = return dv
+      | otherwise   = do { m_contents <- isFilledMetaTyVar_maybe tv
+                         ; case m_contents of
+                             Just ind_ty -> go dv ind_ty
+                             Nothing     -> go_tv dv tv }
 
     go dv (ForAllTy (Bndr tv _) ty)
       = do { dv1 <- collect_cand_qtvs True bound dv (tyVarKind tv)
            ; collect_cand_qtvs is_dep (bound `extendVarSet` tv) dv1 ty }
 
-    is_bound tv = tv `elemVarSet` bound
+    -----------------
+    go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv
+      | is_dep
+      = case tv `elemDVarSet` kvs of
+         True  -> return dv    -- We have met this tyvar aleady
+         False | intersectsVarSet bound (tyCoVarsOfType tv_kind)
+               -> -- See Note [Naughty quantification candidates]
+                  zap_naughty
+               | otherwise
+               -> collect_cand_qtvs True emptyVarSet dv' tv_kind
+               where
+                  dv' = dv { dv_kvs = kvs `extendDVarSet` tv }
+                        -- See Note [Order of accumulation]
 
-    insert_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv
-      | is_dep    = dv { dv_kvs = kvs `extendDVarSet` tv }
-      | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv }
-    -- You might be tempted (like I was) to use unitDVarSet and mappend here.
-    -- However, the union algorithm for deterministic sets depends on (roughly)
-    -- the size of the sets. The elements from the smaller set end up to the
-    -- right of the elements from the larger one. When sets are equal, the
-    -- left-hand argument to `mappend` goes to the right of the right-hand
-    -- argument. In our case, if we use unitDVarSet and mappend, we learn that
-    -- the free variables of (a -> b -> c -> d) are [b, a, c, d], and we then
-    -- quantify over them in that order. (The a comes after the b because we
-    -- union the singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter,
-    -- the size criterion works to our advantage.) This is just annoying to
-    -- users, so I use `extendDVarSet`, which unambiguously puts the new element
-    -- to the right. Note that the unitDVarSet/mappend implementation would not
-    -- be wrong against any specification -- just suboptimal and confounding to users.
+      | otherwise
+      = case tv `elemDVarSet` kvs || tv `elemDVarSet` tvs of
+         True  -> return dv    -- We have met this tyvar aleady
+         False | intersectsVarSet bound (tyCoVarsOfType tv_kind)
+               -> -- See Note [Naughty quantification candidates]
+                  zap_naughty
+               | otherwise
+               -> collect_cand_qtvs True emptyVarSet dv' tv_kind
+               where
+                  dv' = dv { dv_tvs = tvs `extendDVarSet` tv }
+                        -- See Note [Order of accumulation]
+      where
+        tv_kind = tyVarKind tv
+        zap_naughty = do { traceTc "Zapping naughty quantifier" (pprTyVar tv)
+                         ; writeMetaTyVar tv (anyTypeOfKind tv_kind)
+                         ; collect_cand_qtvs True bound dv tv_kind }
 
 collect_cand_qtvs_co :: VarSet -- bound variables
-                     -> CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
+                     -> CandidatesQTvs -> Coercion
+                     -> TcM CandidatesQTvs
 collect_cand_qtvs_co bound = go_co
   where
     go_co dv (Refl ty)             = collect_cand_qtvs True bound dv ty
@@ -1222,13 +1255,9 @@ collect_cand_qtvs_co bound = go_co
     go_co dv (HoleCo hole) = do m_co <- unpackCoercionHole_maybe hole
                                 case m_co of
                                   Just co -> go_co dv co
-                                  Nothing -> return $ insert_cv dv (coHoleCoVar hole)
+                                  Nothing -> go_cv dv (coHoleCoVar hole)
 
-    go_co dv (CoVarCo cv)
-      | is_bound cv
-      = return dv
-      | otherwise
-      = return $ insert_cv dv cv
+    go_co dv (CoVarCo cv) = go_cv dv cv
 
     go_co dv (ForAllCo tcv kind_co co)
       = do { dv1 <- go_co dv kind_co
@@ -1242,16 +1271,36 @@ collect_cand_qtvs_co bound = go_co
     go_prov dv (ProofIrrelProv co) = go_co dv co
     go_prov dv (PluginProv _)      = return dv
 
-    insert_cv dv@(DV { dv_cvs = cvs }) cv
-      = dv { dv_cvs = cvs `extendVarSet` cv }
+    go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs
+    go_cv dv@(DV { dv_cvs = cvs }) cv
+      | is_bound cv         = return dv
+      | cv `elemVarSet` cvs = return dv
+      | otherwise           = collect_cand_qtvs True emptyVarSet
+                                    (dv { dv_cvs = cvs `extendVarSet` cv })
+                                    (idType cv)
 
     is_bound tv = tv `elemVarSet` bound
 
--- | Like 'splitDepVarsOfType', but over a list of types
-candidateQTyVarsOfTypes :: TyCoVarSet  -- zonked global ty/covars
-                        -> [Type] -> TcM CandidatesQTvs
-candidateQTyVarsOfTypes gbl_tvs tys = closeOverKindsCQTvs gbl_tvs =<<
-                                      foldlM (collect_cand_qtvs False gbl_tvs) mempty tys
+{- Note [Order of accumulation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might be tempted (like I was) to use unitDVarSet and mappend
+rather than extendDVarSet.  However, the union algorithm for
+deterministic sets depends on (roughly) the size of the sets. The
+elements from the smaller set end up to the right of the elements from
+the larger one. When sets are equal, the left-hand argument to
+`mappend` goes to the right of the right-hand argument.
+
+In our case, if we use unitDVarSet and mappend, we learn that the free
+variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify
+over them in that order. (The a comes after the b because we union the
+singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter,
+the size criterion works to our advantage.) This is just annoying to
+users, so I use `extendDVarSet`, which unambiguously puts the new
+element to the right.
+
+Note that the unitDVarSet/mappend implementation would not be wrong
+against any specification -- just suboptimal and confounding to users.
+-}
 
 {- *********************************************************************
 *                                                                      *
@@ -1268,7 +1317,7 @@ It takes these free type/kind variables (partitioned into dependent and
 non-dependent variables) and
   1. Zonks them and remove globals and covars
   2. Extends kvs1 with free kind vars in the kinds of tvs (removing globals)
-  3. Calls zonkQuantifiedTyVar on each
+  3. Calls skolemiseQuantifiedTyVar on each
 
 Step (2) is often unimportant, because the kind variable is often
 also free in the type.  Eg
@@ -1309,8 +1358,10 @@ quantifyTyVars
 --   associated type declarations. Also accepts covars, but *never* returns any.
 quantifyTyVars gbl_tvs
                dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs, dv_cvs = covars })
-  = do { traceTc "quantifyTyVars 1" (vcat [ppr dvs, ppr gbl_tvs])
-       ; let mono_tvs = gbl_tvs `unionVarSet` closeOverKinds covars
+  = do { outer_tclvl <- getTcLevel
+       ; traceTc "quantifyTyVars 1" (vcat [ppr outer_tclvl, ppr dvs, ppr gbl_tvs])
+       ; let co_tvs = closeOverKinds covars
+             mono_tvs = gbl_tvs `unionVarSet` co_tvs
               -- NB: All variables in the kind of a covar must not be
               -- quantified over, as we don't quantify over the covar.
 
@@ -1332,19 +1383,33 @@ quantifyTyVars gbl_tvs
                  --    they are all in dep_tkvs
                  -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV
 
-               -- See Note [Naughty quantification candidates]
-             (naughty_deps, final_dep_kvs)       = partition (is_naughty_tv mono_tvs) dep_kvs
-             (naughty_nondeps, final_nondep_tvs) = partition (is_naughty_tv mono_tvs) nondep_tvs
-
-       ; mapM_ zap_naughty_tv (naughty_deps ++ naughty_nondeps)
+       -- This block uses level numbers to decide what to quantify
+       -- and emits a warning if the two methods do not give the same answer
+       ; let dep_kvs2    = dVarSetElemsWellScoped $
+                           filterDVarSet (quantifiableTv outer_tclvl) dep_tkvs
+             nondep_tvs2 = filter (quantifiableTv outer_tclvl) $
+                           dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs)
+
+             all_ok = dep_kvs == dep_kvs2 && nondep_tvs == nondep_tvs2
+             bad_msg = hang (text "Quantification by level numbers would fail")
+                          2 (vcat [ text "Outer level =" <+> ppr outer_tclvl
+                                  , text "dep_tkvs ="    <+> ppr dep_tkvs
+                                  , text "co_vars ="     <+> vcat [ ppr cv <+> dcolon <+> ppr (varType cv)
+                                                                  | cv <- nonDetEltsUniqSet covars ]
+                                  , text "co_tvs ="      <+> ppr co_tvs
+                                  , text "dep_kvs ="     <+> ppr dep_kvs
+                                  , text "dep_kvs2 ="    <+> ppr dep_kvs2
+                                  , text "nondep_tvs ="  <+> ppr nondep_tvs
+                                  , text "nondep_tvs2 =" <+> ppr nondep_tvs2 ])
+       ; WARN( not all_ok, bad_msg ) return ()
 
              -- In the non-PolyKinds case, default the kind variables
              -- to *, and zonk the tyvars as usual.  Notice that this
              -- may make quantifyTyVars return a shorter list
              -- than it was passed, but that's ok
        ; poly_kinds  <- xoptM LangExt.PolyKinds
-       ; dep_kvs'    <- mapMaybeM (zonk_quant (not poly_kinds)) final_dep_kvs
-       ; nondep_tvs' <- mapMaybeM (zonk_quant False)            final_nondep_tvs
+       ; dep_kvs'    <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs
+       ; nondep_tvs' <- mapMaybeM (zonk_quant False)            nondep_tvs
        ; let final_qtvs = dep_kvs' ++ nondep_tvs'
            -- Because of the order, any kind variables
            -- mentioned in the kinds of the nondep_tvs'
@@ -1364,11 +1429,6 @@ quantifyTyVars gbl_tvs
 
        ; return final_qtvs }
   where
-    -- See Note [Naughty quantification candidates]
-    is_naughty_tv mono_tvs tv
-      = anyVarSet (isSkolemTyVar <&&> (not . (`elemVarSet` mono_tvs))) $
-        tyCoVarsOfType (tyVarKind tv)
-
     -- zonk_quant returns a tyvar if it should be quantified over;
     -- otherwise, it returns Nothing. The latter case happens for
     --    * Kind variables, with -XNoPolyKinds: don't quantify over these
@@ -1378,21 +1438,28 @@ quantifyTyVars gbl_tvs
       = return Nothing   -- this can happen for a covar that's associated with
                          -- a coercion hole. Test case: typecheck/should_compile/T2494
 
-      | not (isTcTyVar tkv)
-      = return (Just tkv)  -- For associated types, we have the class variables
-                           -- in scope, and they are TyVars not TcTyVars
+      | not (isTcTyVar tkv)  -- I don't think this can ever happen.
+                             -- Hence the assert
+      = ASSERT2( False, text "quantifying over a TyVar" <+> ppr tkv)
+        return (Just tkv)
+
       | otherwise
       = do { deflt_done <- defaultTyVar default_kind tkv
            ; case deflt_done of
                True  -> return Nothing
-               False -> do { tv <- zonkQuantifiedTyVar tkv
+               False -> do { tv <- skolemiseQuantifiedTyVar tkv
                            ; return (Just tv) } }
 
-    zap_naughty_tv tv
-      = WARN(True, text "naughty quantification candidate: " <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv))
-        writeMetaTyVar tv (anyTypeOfKind (tyVarKind tv))
+quantifiableTv :: TcLevel   -- Level of the context, outside the quantification
+               -> TcTyVar
+               -> Bool
+quantifiableTv outer_tclvl tcv
+  | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separtely
+  = tcTyVarLevel tcv > outer_tclvl
+  | otherwise
+  = False
 
-zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
+skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
 -- The quantified type variables often include meta type variables
 -- we want to freeze them into ordinary type variables
 -- The meta tyvar is updated to point to the new skolem TyVar.  Now any
@@ -1404,7 +1471,7 @@ zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
 -- This function is called on both kind and type variables,
 -- but kind variables *only* if PolyKinds is on.
 
-zonkQuantifiedTyVar tv
+skolemiseQuantifiedTyVar tv
   = case tcTyVarDetails tv of
       SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv)
                         ; return (setTyVarKind tv kind) }
@@ -1413,7 +1480,7 @@ zonkQuantifiedTyVar tv
 
       MetaTv {} -> skolemiseUnboundMetaTyVar tv
 
-      _other -> pprPanic "zonkQuantifiedTyVar" (ppr tv) -- RuntimeUnk
+      _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk
 
 defaultTyVar :: Bool      -- True <=> please default this kind variable to *
              -> TcTyVar   -- If it's a MetaTyVar then it is unbound
@@ -1427,7 +1494,7 @@ defaultTyVar default_kind tv
     -- Do not default TyVarTvs. Doing so would violate the invariants
     -- on TyVarTvs; see Note [Signature skolems] in TcType.
     -- Trac #13343 is an example; #14555 is another
-    -- See Note [Kind generalisation and TyVarTvs]
+    -- See Note [Inferring kinds for type declarations] in TcTyClsDecls
   = return False
 
 
@@ -1671,13 +1738,13 @@ zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv
                | otherwise    = ASSERT2( isCoVar tv, ppr tv )
                                 mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv
    -- Hackily, when typechecking type and class decls
-   -- we have TyVars in scopeadded (only) in
-   -- TcHsType.tcTyClTyVars, but it seems
+   -- we have TyVars in scope added (only) in
+   -- TcHsType.bindTyClTyVars, but it seems
    -- painful to make them into TcTyVars there
 
 zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet
-zonkTyCoVarsAndFV tycovars =
-  tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars)
+zonkTyCoVarsAndFV tycovars
+  tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars)
   -- It's OK to use nonDetEltsUniqSet here because we immediately forget about
   -- the ordering by turning it into a nondeterministic set and the order
   -- of zonking doesn't matter for determinism.
@@ -1685,8 +1752,8 @@ zonkTyCoVarsAndFV tycovars =
 -- Takes a list of TyCoVars, zonks them and returns a
 -- deterministically ordered list of their free variables.
 zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar]
-zonkTyCoVarsAndFVList tycovars =
-  tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars
+zonkTyCoVarsAndFVList tycovars
+  tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars
 
 zonkTcTyVars :: [TcTyVar] -> TcM [TcType]
 zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars
index 7ac0dd4..19ec6de 100644 (file)
@@ -410,7 +410,7 @@ tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside
 tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside
   = do  { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
                                                             sig_ty pat_ty
-                -- Using tcExtendNameTyVarEnv is appropriate here (not scopeTyVars2)
+                -- Using tcExtendNameTyVarEnv is appropriate here
                 -- because we're not really bringing fresh tyvars into scope.
                 -- We're *naming* existing tyvars. Note that it is OK for a tyvar
                 -- from an outer scope to mention one of these tyvars in its kind.
index eefdb97..4942a8b 100644 (file)
@@ -146,23 +146,29 @@ tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details
                tcPat PatSyn lpat exp_ty        $
                mapM tcLookupId arg_names
 
-       ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
-
-       ; (qtvs, req_dicts, ev_binds, residual, _)
+       ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
+
+             named_taus = (name, pat_ty) : map mk_named_tau args
+             mk_named_tau arg
+               = (getName arg, mkSpecForAllTys ex_tvs (varType arg))
+               -- The mkSpecForAllTys is important (Trac #14552), albeit
+               -- slightly artifical (there is no variable with this funny type).
+               -- We do not want to quantify over variable (alpha::k)
+               -- that mention the existentially-bound type variables
+               -- ex_tvs in its kind k.
+               -- See Note [Type variables whose kind is captured]
+
+       ; (univ_tvs, req_dicts, ev_binds, residual, _)
                <- simplifyInfer tclvl NoRestrictions [] named_taus wanted
        ; top_ev_binds <- checkNoErrs (simplifyTop residual)
        ; addTopEvBinds top_ev_binds $
 
-    do { let (ex_tvs, prov_dicts) = tcCollectEx lpat'
-             ex_tv_set  = mkVarSet ex_tvs
-             univ_tvs   = filterOut (`elemVarSet` ex_tv_set) qtvs
-             req_theta  = map evVarPred req_dicts
-
-       ; prov_dicts <- mapM zonkId prov_dicts
+    do { prov_dicts <- mapM zonkId prov_dicts
        ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts
              -- Filtering: see Note [Remove redundant provided dicts]
              (prov_theta, prov_evs)
                  = unzip (mapMaybe mkProvEvidence filtered_prov_dicts)
+             req_theta = map evVarPred req_dicts
 
        -- Report coercions that esacpe
        -- See Note [Coercions that escape]
@@ -226,7 +232,37 @@ dependentArgErr (arg, bad_cos)
   where
     bad_co_list = dVarSetElems bad_cos
 
-{- Note [Remove redundant provided dicts]
+{- Note [Type variables whose kind is captured]
+~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data AST a = Sym [a]
+  class Prj s where { prj :: [a] -> Maybe (s a)
+  pattern P x <= Sym (prj -> Just x)
+
+Here we get a matcher with this type
+  $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r
+
+No problem.  But note that 's' is not fixed by the type of the
+pattern (AST a), nor is it existentially bound.  It's really only
+fixed by the type of the continuation.
+
+Trac #14552 showed that this can go wrong if the kind of 's' mentions
+existentially bound variables.  We obviously can't make a type like
+  $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r)
+                                   -> r -> r
+But neither is 's' itself existentially bound, so the forall (s::k->*)
+can't go in the inner forall either.  (What would the matcher apply
+the continuation to?)
+
+Solution: do not quantiify over any unification variable whose kind
+mentions the existentials.  We can conveniently do that by making the
+"taus" passed to simplifyInfer look like
+   forall ex_tvs. arg_ty
+
+After that, Note [Naughty quantification candidates] in TcMType takes
+over, and zonks any such naughty variables to Any.
+
+Note [Remove redundant provided dicts]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Recall that
    HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2)
index c65a3b9..dfa6177 100644 (file)
@@ -79,13 +79,14 @@ import TcRnExports
 import TcEvidence
 import qualified BooleanFormula as BF
 import PprTyThing( pprTyThingInContext )
-import Coercion( pprCoAxiom )
 import CoreFVs( orphNamesOfFamInst )
 import FamInst
 import InstEnv
-import FamInstEnv
+import FamInstEnv( FamInst, pprFamInst, famInstsRepTyCons
+                 , famInstEnvElts, extendFamInstEnvList, normaliseType )
 import TcAnnotations
 import TcBinds
+import MkIface          ( coAxiomToIfaceDecl )
 import HeaderInfo       ( mkPrelImports )
 import TcDefaults
 import TcEnv
@@ -1889,7 +1890,7 @@ However the GHCi debugger creates top-level bindings for Ids whose
 types have free RuntimeUnk skolem variables, standing for unknown
 types.  If we don't register these free TyVars as global TyVars then
 the typechecker will try to quantify over them and fall over in
-zonkQuantifiedTyVar. so we must add any free TyVars to the
+skolemiseQuantifiedTyVar. so we must add any free TyVars to the
 typechecker's global TyVar set.  That is most conveniently by using
 tcExtendLocalTypeEnv, which automatically extends the global TyVar
 set.
@@ -2731,7 +2732,7 @@ ppr_types debug type_env
 ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc
 ppr_tycons debug fam_insts type_env
   = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons
-         , ppr_things "COERCION AXIOMS" pprCoAxiom
+         , ppr_things "COERCION AXIOMS" ppr_ax
                       (typeEnvCoAxioms type_env) ]
   where
     fi_tycons = famInstsRepTyCons fam_insts
@@ -2747,7 +2748,7 @@ ppr_tycons debug fam_insts type_env
        = vcat [ ppWhen show_roles $
                 hang (text "type role" <+> ppr tc)
                    2 (hsep (map ppr roles))
-              , hang (ppr tc <+> dcolon)
+              , hang (ppr tc <> braces (ppr (tyConArity tc)) <+> dcolon)
                    2 (ppr (tidyTopType (tyConKind tc))) ]
        where
          show_roles = debug || not (all (== boring_role) roles)
@@ -2756,6 +2757,8 @@ ppr_tycons debug fam_insts type_env
                      | otherwise       = Representational
             -- Matches the choice in IfaceSyn, calls to pprRoles
 
+    ppr_ax ax = ppr (coAxiomToIfaceDecl ax)
+
 ppr_datacons :: Bool -> TypeEnv -> SDoc
 ppr_datacons debug type_env
   = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs
index 667d866..fe769a9 100644 (file)
@@ -1542,21 +1542,23 @@ pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
 pushLevelAndCaptureConstraints thing_inside
   = do { env <- getLclEnv
        ; let tclvl' = pushTcLevel (tcl_tclvl env)
+       ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')
        ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
                        captureConstraints thing_inside
+       ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')
        ; return (tclvl', lie, res) }
 
 pushTcLevelM_ :: TcM a -> TcM a
 pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
 
-pushTcLevelM :: TcM a -> TcM (a, TcLevel)
+pushTcLevelM :: TcM a -> TcM (TcLevel, a)
 -- See Note [TcLevel assignment] in TcType
 pushTcLevelM thing_inside
   = do { env <- getLclEnv
        ; let tclvl' = pushTcLevel (tcl_tclvl env)
        ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
                           thing_inside
-       ; return (res, tclvl') }
+       ; return (tclvl', res) }
 
 -- Returns pushed TcLevel
 pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
index 04f17cc..ad3122b 100644 (file)
@@ -1984,8 +1984,12 @@ tyCoFVsOfImplic :: Implication -> FV
 tyCoFVsOfImplic (Implic { ic_skols = skols
                         , ic_given = givens
                         , ic_wanted = wanted })
-  = FV.delFVs (mkVarSet skols `unionVarSet` mkVarSet givens)
-      (tyCoFVsOfWC wanted `unionFV` tyCoFVsOfTypes (map evVarPred givens))
+  | isEmptyWC wanted
+  = emptyFV
+  | otherwise
+  = tyCoFVsVarBndrs skols  $
+    tyCoFVsVarBndrs givens $
+    tyCoFVsOfWC wanted
 
 tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV
 tyCoFVsOfBag tvs_of = foldrBag (unionFV . tvs_of) emptyFV
@@ -3507,8 +3511,10 @@ data CtOrigin
   | NegateOrigin                        -- Occurrence of syntactic negation
 
   | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc
+  | AssocFamPatOrigin   -- When matching the patterns of an associated
+                        -- family instance with that of its parent class
   | SectionOrigin
-  | TupleOrigin                        -- (..,..)
+  | TupleOrigin         -- (..,..)
   | ExprSigOrigin       -- e :: ty
   | PatSigOrigin        -- p :: ty
   | PatOrigin           -- Instantiating a polytyped pattern at a constructor
@@ -3726,6 +3732,9 @@ pprCtOrigin (KindEqOrigin t1 (Just t2) _ _)
   = hang (ctoHerald <+> text "a kind equality arising from")
        2 (sep [ppr t1, char '~', ppr t2])
 
+pprCtOrigin AssocFamPatOrigin
+  = text "when matching a family LHS with its class instance head"
+
 pprCtOrigin (KindEqOrigin t1 Nothing _ _)
   = hang (ctoHerald <+> text "a kind equality when matching")
        2 (ppr t1)
@@ -3797,6 +3806,7 @@ pprCtO IfOrigin              = text "an if expression"
 pprCtO (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)]
 pprCtO (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)]
 pprCtO SectionOrigin         = text "an operator section"
+pprCtO AssocFamPatOrigin     = text "the LHS of a famly instance"
 pprCtO TupleOrigin           = text "a tuple"
 pprCtO NegateOrigin          = text "a use of syntactic negation"
 pprCtO (ScOrigin n)          = text "the superclasses of an instance declaration"
index 4bcd203..2955704 100644 (file)
@@ -83,11 +83,11 @@ tcRule (HsRule { rd_ext  = ext
     do { traceTc "---- Rule ------" (pprFullRuleName rname)
 
         -- Note [Typechecking rules]
-       ; (stuff,_) <- pushTcLevelM $
-                      generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
+       ; (tc_lvl, stuff) <- pushTcLevelM $
+                            generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
 
        ; let (tv_bndrs, id_bndrs, lhs', lhs_wanted
-                                , rhs', rhs_wanted, rule_ty, tc_lvl) = stuff
+                                , rhs', rhs_wanted, rule_ty) = stuff
 
        ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname
                                   , ppr lhs_wanted
@@ -112,7 +112,7 @@ tcRule (HsRule { rd_ext  = ext
        ; let tpl_ids = lhs_evs ++ id_bndrs
        ; gbls  <- tcGetGlobalTyCoVars -- Even though top level, there might be top-level
                                       -- monomorphic bindings from the MR; test tc111
-       ; forall_tkvs <- candidateQTyVarsOfTypes gbls $
+       ; forall_tkvs <- candidateQTyVarsOfTypes $
                         map (mkSpecForAllTys tv_bndrs) $  -- don't quantify over lexical tyvars
                         rule_ty : map idType tpl_ids
        ; qtkvs <- quantifyTyVars gbls forall_tkvs
@@ -152,40 +152,34 @@ generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
                                , [TcId]
                                , LHsExpr GhcTc, WantedConstraints
                                , LHsExpr GhcTc, WantedConstraints
-                               , TcType
-                               , TcLevel )
+                               , TcType )
 generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
-  = do { ((tv_bndrs, id_bndrs, lvl), bndr_wanted) <- captureConstraints $
-                                                     tcRuleBndrs ty_bndrs tm_bndrs
+  = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $
+                                                tcRuleBndrs ty_bndrs tm_bndrs
               -- bndr_wanted constraints can include wildcard hole
               -- constraints, which we should not forget about.
               -- It may mention the skolem type variables bound by
               -- the RULE.  c.f. Trac #10072
 
-       ; setTcLevel lvl $
-         tcExtendTyVarEnv tv_bndrs $
+       ; tcExtendTyVarEnv tv_bndrs $
          tcExtendIdEnv    id_bndrs $
     do { -- See Note [Solve order for RULES]
          ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
        ; (rhs',            rhs_wanted) <- captureConstraints $
                                           tcMonoExpr rhs (mkCheckExpType rule_ty)
        ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted
-       ; return (tv_bndrs, id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty, lvl) } }
+       ; return (tv_bndrs, id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }
 
 -- See Note [TcLevel in type checking rules]
 tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
-            -> TcM ([TcTyVar],[Id],TcLevel)
+            -> TcM ([TcTyVar], [Id])
 tcRuleBndrs (Just bndrs) xs
-  = do { (tys1,(tys2,tms,lvl)) <- tcExplicitTKBndrs
-                                  (ForAllSkol (pprHsExplicitForAll (Just bndrs)))
-                                  bndrs $ do { lvl <- getTcLevel
-                                             ; (tys,tms) <- tcRuleTmBndrs xs
-                                             ; return (tys,tms,lvl) }
-       ; return (tys1 ++ tys2, tms, lvl) }
+  = do { (tys1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $
+                              tcRuleTmBndrs xs
+       ; return (tys1 ++ tys2, tms) }
+
 tcRuleBndrs Nothing xs
-  = do { lvl <- getTcLevel
-       ; (tys,tms) <- tcRuleTmBndrs xs
-       ; return (tys,tms,lvl) }
+  = tcRuleTmBndrs xs
 
 -- See Note [TcLevel in type checking rules]
 tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])
index adcfdbe..69f58b9 100644 (file)
@@ -2868,7 +2868,7 @@ checkTvConstraintsTcS skol_info skol_tvs (TcS thing_inside)
                          -- does not emit any work-list constraints
              new_tcs_env = tcs_env { tcs_worklist = wl_panic }
 
-       ; ((res, wanteds), new_tclvl) <- TcM.pushTcLevelM $
+       ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $
                                         thing_inside new_tcs_env
 
        ; unless (null wanteds) $
@@ -2908,7 +2908,7 @@ checkConstraintsTcS skol_info skol_tvs given (TcS thing_inside)
                          -- does not emit any work-list constraints
              new_tcs_env = tcs_env { tcs_worklist = wl_panic }
 
-       ; ((res, wanteds), new_tclvl) <- TcM.pushTcLevelM $
+       ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $
                                         thing_inside new_tcs_env
 
        ; ev_binds_var <- TcM.newTcEvBinds
index f7a41e5..5925fc8 100644 (file)
@@ -42,8 +42,6 @@ import Type( mkTyVarBinders )
 
 import DynFlags
 import Var      ( TyVar, tyVarKind )
-import VarSet
-import VarEnv   ( mkInScopeSet )
 import Id       ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )
 import PrelNames( mkUnboundName )
 import BasicTypes
@@ -311,7 +309,7 @@ equalites, rather than leaving them in the ambient constraints
 to be solved later.  Pattern synonyms are top-level, so there's
 no problem with completely solving them.
 
-(NB: this solveEqualities wraps tcImplicitTKBndrs, which itself
+(NB: this solveEqualities wraps newImplicitTKBndrs, which itself
 does a solveLocalEqualities; so solveEqualities isn't going to
 make any further progress; it'll just report any unsolved ones,
 and fail, as it should.)
@@ -327,11 +325,11 @@ tcPatSynSig name sig_ty
   , (ex_hs_tvs,   hs_prov, hs_body_ty) <- splitLHsSigmaTy hs_ty1
   = do {  traceTc "tcPatSynSig 1" (ppr sig_ty)
        ; (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty))))
-           <- solveEqualities                             $
-                -- See Note [solveEqualities in tcPatSynSig]
-              tcImplicitTKBndrs skol_info implicit_hs_tvs $
-              tcExplicitTKBndrs skol_info univ_hs_tvs     $
-              tcExplicitTKBndrs skol_info ex_hs_tvs       $
+           <- pushTcLevelM_   $
+              solveEqualities $ -- See Note [solveEqualities in tcPatSynSig]
+              bindImplicitTKBndrs_Skol implicit_hs_tvs $
+              bindExplicitTKBndrs_Skol univ_hs_tvs     $
+              bindExplicitTKBndrs_Skol ex_hs_tvs       $
               do { req     <- tcHsContext hs_req
                  ; prov    <- tcHsContext hs_prov
                  ; body_ty <- tcHsOpenType hs_body_ty
@@ -349,7 +347,7 @@ tcPatSynSig name sig_ty
        -- These are /signatures/ so we zonk to squeeze out any kind
        -- unification variables.  Do this after kindGeneralize which may
        -- default kind variables to *.
-       ; implicit_tvs <- mapM zonkTyCoVarKind implicit_tvs
+       ; implicit_tvs <- zonkAndScopedSort implicit_tvs
        ; univ_tvs     <- mapM zonkTyCoVarKind univ_tvs
        ; ex_tvs       <- mapM zonkTyCoVarKind ex_tvs
        ; req          <- zonkTcTypes req
@@ -359,6 +357,7 @@ tcPatSynSig name sig_ty
        -- Skolems have TcLevels too, though they're used only for debugging.
        -- If you don't do this, the debugging checks fail in TcPatSyn.
        -- Test case: patsyn/should_compile/T13441
+{-
        ; tclvl <- getTcLevel
        ; let env0                  = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs
              (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs
@@ -367,6 +366,13 @@ tcPatSynSig name sig_ty
              req'                  = substTys env3 req
              prov'                 = substTys env3 prov
              body_ty'              = substTy  env3 body_ty
+-}
+      ; let implicit_tvs' = implicit_tvs
+            univ_tvs'     = univ_tvs
+            ex_tvs'       = ex_tvs
+            req'          = req
+            prov'         = prov
+            body_ty'      = body_ty
 
        -- Now do validity checking
        ; checkValidType ctxt $
@@ -395,7 +401,6 @@ tcPatSynSig name sig_ty
                       , patsig_body_ty        = body_ty' }) }
   where
     ctxt = PatSynCtxt name
-    skol_info = SigTypeSkol ctxt
 
     build_patsyn_type kvs imp univ req ex prov body
       = mkInvForAllTys kvs $
@@ -432,11 +437,12 @@ tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc })
                       , sig_inst_theta = theta
                       , sig_inst_tau   = tau }) }
 
-tcInstSig sig@(PartialSig { psig_hs_ty = hs_ty
-                          , sig_ctxt = ctxt
-                          , sig_loc = loc })
+tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty
+                             , sig_ctxt = ctxt
+                             , sig_loc = loc })
   = setSrcSpan loc $  -- Set the binding site of the tyvars
-    do { (wcs, wcx, tv_names, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty
+    do { traceTc "Staring partial sig {" (ppr hs_sig)
+       ; (wcs, wcx, tv_names, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty
 
         -- Clone the quantified tyvars
         -- Reason: we might have    f, g :: forall a. a -> _ -> a
@@ -445,31 +451,18 @@ tcInstSig sig@(PartialSig { psig_hs_ty = hs_ty
         --         the easiest way to do so, and is very similar to
         --         the tcInstType in the CompleteSig case
         -- See Trac #14643
-       ; let in_scope = mkInScopeSet $ closeOverKinds $ unionVarSets
-                          [ mkVarSet (map snd wcs)
-                          , maybe emptyVarSet tyCoVarsOfType wcx
-                          , mkVarSet tvs
-                          , tyCoVarsOfTypes theta
-                          , tyCoVarsOfType tau ]
-               -- the in_scope is a bit bigger than nec'y, but too big is always
-               -- safe
-             empty_subst = mkEmptyTCvSubst in_scope
-       ; (subst, tvs') <- instSkolTyCoVarsX mk_sig_tv empty_subst tvs
+       ; (subst, tvs') <- newMetaTyVarTyVars tvs
+                         -- Why newMetaTyVarTyVars?  See TcBinds
+                         -- Note [Quantified variables in partial type signatures]
        ; let tv_prs = tv_names `zip` tvs'
-
-       ; return (TISI { sig_inst_sig   = sig
-                      , sig_inst_skols = tv_prs
-                      , sig_inst_wcs   = wcs
-                      , sig_inst_wcx   = wcx
-                      , sig_inst_theta = substTys subst theta
-                      , sig_inst_tau   = substTy  subst tau
-                }) }
-  where
-    mk_sig_tv old_name kind
-      = do { uniq <- newUnique
-           ; newTyVarTyVar (setNameUnique old_name uniq) kind }
-      -- Why newTyVarTyVar?  See TcBinds
-      -- Note [Quantified variables in partial type signatures]
+             inst_sig = TISI { sig_inst_sig   = hs_sig
+                             , sig_inst_skols = tv_prs
+                             , sig_inst_wcs   = wcs
+                             , sig_inst_wcx   = wcx
+                             , sig_inst_theta = substTys subst theta
+                             , sig_inst_tau   = substTy  subst tau }
+       ; traceTc "End partial sig }" (ppr inst_sig)
+       ; return inst_sig }
 
 
 {- Note [Pattern bindings and complete signatures]
index 6ef62c8..ac283fa 100644 (file)
@@ -7,7 +7,7 @@ module TcSimplify(
        simplifyDefault,
        simplifyTop, simplifyTopImplic,
        simplifyInteractive,
-       solveEqualities, solveLocalEqualities,
+       solveEqualities, solveLocalEqualities, solveLocalEqualitiesX,
        simplifyWantedsTcM,
        tcCheckSatisfiability,
        tcNormalise,
@@ -121,9 +121,7 @@ simplifyTop wanteds
                ; return (final_wc, unsafe_ol) }
        ; traceTc "End simplifyTop }" empty
 
-       ; traceTc "reportUnsolved {" empty
        ; binds2 <- reportUnsolved final_wc
-       ; traceTc "reportUnsolved }" empty
 
        ; traceTc "reportUnsolved (unsafe overlapping) {" empty
        ; unless (isEmptyCts unsafe_ol) $ do {
@@ -145,24 +143,30 @@ simplifyTop wanteds
 
        ; return (evBindMapBinds binds1 `unionBags` binds2) }
 
+
 -- | Type-check a thing that emits only equality constraints, solving any
 -- constraints we can and re-emitting constraints that we can't. The thing_inside
 -- should generally bump the TcLevel to make sure that this run of the solver
 -- doesn't affect anything lying around.
-solveLocalEqualities :: TcM a -> TcM a
-solveLocalEqualities thing_inside
-  = do { traceTc "solveLocalEqualities {" empty
+solveLocalEqualities :: String -> TcM a -> TcM a
+solveLocalEqualities callsite thing_inside
+  = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside
+       ; emitConstraints wanted
+       ; return res }
+
+solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a)
+solveLocalEqualitiesX callsite thing_inside
+  = do { traceTc "solveLocalEqualitiesX {" (vcat [ text "Called from" <+> text callsite ])
 
        ; (result, wanted) <- captureConstraints thing_inside
 
-       ; traceTc "solveLocalEqualities: running solver {" (ppr wanted)
-       ; reduced_wanted <- runTcSEqualities (solveWanteds wanted)
-       ; traceTc "solveLocalEqualities: running solver }" (ppr reduced_wanted)
+       ; traceTc "solveLocalEqualities: running solver" (ppr wanted)
+       ; residual_wanted <- runTcSEqualities (solveWanteds wanted)
 
-       ; emitConstraints reduced_wanted
+       ; traceTc "solveLocalEqualitiesX end }" $
+         text "residual_wanted =" <+> ppr residual_wanted
 
-       ; traceTc "solveLocalEqualities end }" empty
-       ; return result }
+       ; return (residual_wanted, result) }
 
 -- | Type-check a thing that emits only equality constraints, then
 -- solve those constraints. Fails outright if there is trouble.
@@ -171,16 +175,18 @@ solveLocalEqualities thing_inside
 solveEqualities :: TcM a -> TcM a
 solveEqualities thing_inside
   = checkNoErrs $  -- See Note [Fail fast on kind errors]
-    do { (result, wanted) <- captureConstraints thing_inside
-       ; traceTc "solveEqualities {" $ text "wanted = " <+> ppr wanted
+    do { lvl <- TcM.getTcLevel
+       ; traceTc "solveEqualities {" (text "level =" <+> ppr lvl)
+
+       ; (result, wanted) <- captureConstraints thing_inside
+
+       ; traceTc "solveEqualities: running solver" $ text "wanted = " <+> ppr wanted
        ; final_wc <- runTcSEqualities $ simpl_top wanted
           -- NB: Use simpl_top here so that we potentially default RuntimeRep
           -- vars to LiftedRep. This is needed to avoid #14991.
-       ; traceTc "End solveEqualities }" empty
 
-       ; traceTc "reportAllUnsolved {" empty
+       ; traceTc "End solveEqualities }" empty
        ; reportAllUnsolved final_wc
-       ; traceTc "reportAllUnsolved }" empty
        ; return result }
 
 -- | Simplify top-level constraints, but without reporting any unsolved
@@ -514,9 +520,7 @@ simplifyDefault theta
   = do { traceTc "simplifyDefault" empty
        ; wanteds  <- newWanteds DefaultOrigin theta
        ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds))
-       ; traceTc "reportUnsolved {" empty
        ; reportAllUnsolved unsolved
-       ; traceTc "reportUnsolved }" empty
        ; return () }
 
 ------------------
@@ -674,7 +678,7 @@ simplifyInfer :: TcLevel               -- Used when generating the constraints
 simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
   | isEmptyWC wanteds
   = do { gbl_tvs <- tcGetGlobalTyCoVars
-       ; dep_vars <- candidateQTyVarsOfTypes gbl_tvs (map snd name_taus)
+       ; dep_vars <- candidateQTyVarsOfTypes (map snd name_taus)
        ; qtkvs <- quantifyTyVars gbl_tvs dep_vars
        ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)
        ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) }
@@ -1084,7 +1088,7 @@ defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates
 
        -- Default any kind/levity vars
        ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}
-                <- candidateQTyVarsOfTypes mono_tvs candidates
+                <- candidateQTyVarsOfTypes candidates
                 -- any covars should already be handled by
                 -- the logic in decideMonoTyVars, which looks at
                 -- the constraints generated
@@ -1154,15 +1158,18 @@ decideQuantifiedTyVars mono_tvs name_taus psigs candidates
        -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces
        -- them in that order, so that the final qtvs quantifies in the same
        -- order as the partial signatures do (Trac #13524)
-       ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes mono_tvs $
+       ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $
                                                          psig_tys ++ candidates ++ tau_tys
        ; let pick     = (`dVarSetIntersectVarSet` grown_tcvs)
              dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }
 
        ; traceTc "decideQuantifiedTyVars" (vcat
-           [ text "seed_tys =" <+> ppr seed_tys
+           [ text "candidates =" <+> ppr candidates
+           , text "tau_tys =" <+> ppr tau_tys
+           , text "seed_tys =" <+> ppr seed_tys
            , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys)
-           , text "grown_tcvs =" <+> ppr grown_tcvs])
+           , text "grown_tcvs =" <+> ppr grown_tcvs
+           , text "dvs =" <+> ppr dvs_plus])
 
        ; quantifyTyVars mono_tvs dvs_plus }
 
@@ -2003,9 +2010,10 @@ promoteTyVarTcS tv
 defaultTyVarTcS :: TcTyVar -> TcS Bool
 defaultTyVarTcS the_tv
   | isRuntimeRepVar the_tv
-  , not (isTyVarTyVar the_tv)  -- TyVarTvs should only be unified with a tyvar
-                             -- never with a type; c.f. TcMType.defaultTyVar
-                             -- See Note [Kind generalisation and TyVarTvs]
+  , not (isTyVarTyVar the_tv)
+    -- TyVarTvs should only be unified with a tyvar
+    -- never with a type; c.f. TcMType.defaultTyVar
+    -- and Note [Inferring kinds for type declarations] in TcTyClsDecls
   = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)
        ; unifyTyVar the_tv liftedRepTy
        ; return True }
@@ -2139,7 +2147,7 @@ approximateWC to produce a list of candidate constraints.  Then we MUST
 To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we
 have an instance (C ((x:*) -> Int)).  The instance doesn't match -- but it
 should!  If we don't solve the constraint, we'll stupidly quantify over
-(C (a->Int)) and, worse, in doing so zonkQuantifiedTyVar will quantify over
+(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over
 (b:*) instead of (a:OpenKind), which can lead to disaster; see Trac #7332.
 Trac #7641 is a simpler example.
 
index b3cf4d9..d3e1464 100644 (file)
@@ -46,6 +46,7 @@ import SrcLoc
 import THNames
 import TcUnify
 import TcEnv
+import Coercion( etaExpandCoAxBranch )
 import FileCleanup ( newTempName, TempFileLifetime(..) )
 
 import Control.Monad
@@ -1189,8 +1190,9 @@ reifyInstances th_nm th_tys
                do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
                   ; return ((tv_names, rn_ty), fvs) }
         ; (_tvs, ty)
-            <- failIfEmitsConstraints $  -- avoid error cascade if there are unsolved
-               tcImplicitTKBndrs ReifySkol tv_names $
+            <- pushTcLevelM_   $
+               solveEqualities $ -- Avoid error cascade if there are unsolved
+               bindImplicitTKBndrs_Skol tv_names $
                fst <$> tcLHsType rn_ty
         ; ty <- zonkTcTypeToType ty
                 -- Substitute out the meta type variables
@@ -1692,15 +1694,16 @@ reifyFamilyInstances fam_tc fam_insts
 reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
                               -- includes only *visible* tvs
                     -> FamInst -> TcM TH.Dec
-reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
-                                              , fi_fam = fam
-                                              , fi_tvs = fam_tvs
-                                              , fi_tys = lhs
-                                              , fi_rhs = rhs })
+reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor
+                                         , fi_axiom = ax
+                                         , fi_fam = fam })
+  | let fam_tc = coAxiomTyCon ax
+        branch = coAxiomSingleBranch ax
+  , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch
   = case flavor of
       SynFamilyInst ->
                -- remove kind patterns (#8884)
-        do { th_tvs <- reifyTyVarsToMaybe fam_tvs
+        do { th_tvs <- reifyTyVarsToMaybe tvs
            ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
            ; th_lhs <- reifyTypes lhs_types_only
            ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
@@ -1713,10 +1716,10 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
         do { let -- eta-expand lhs types, because sometimes data/newtype
                  -- instances are eta-reduced; See Trac #9692
                  -- See Note [Eta reduction for data families] in FamInstEnv
-                 (ee_tvs, ee_lhs, _) = etaExpandFamInst fam_tvs lhs rhs
-                 fam'                = reifyName fam
-                 dataCons            = tyConDataCons rep_tc
-                 isGadt              = isGadtSyntaxTyCon rep_tc
+                 (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch
+                 fam'     = reifyName fam
+                 dataCons = tyConDataCons rep_tc
+                 isGadt   = isGadtSyntaxTyCon rep_tc
            ; th_tvs <- reifyTyVarsToMaybe ee_tvs
            ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons
            ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs
@@ -1727,8 +1730,6 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
                then TH.NewtypeInstD [] fam' th_tvs annot_th_tys Nothing (head cons) []
                else TH.DataInstD    [] fam' th_tvs annot_th_tys Nothing       cons  []
            }
-  where
-    fam_tc = famInstTyCon inst
 
 ------------------------------
 reifyType :: TyCoRep.Type -> TcM TH.Type
index 8fbfc33..c097d50 100644 (file)
@@ -15,10 +15,11 @@ module TcTyClsDecls (
 
         -- Functions used by TcInstDcls to check
         -- data/type family instance declarations
-        kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon,
+        kcConDecl, tcConDecls, dataDeclChecks, checkValidTyCon,
         tcFamTyPats, tcTyFamInstEqn,
         tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
-        wrongKindOfFamily, dataConCtxt
+        unravelFamInstPats,
+        wrongKindOfFamily
     ) where
 
 #include "HsVersions.h"
@@ -36,9 +37,9 @@ import TcTyDecls
 import TcClassDcl
 import {-# SOURCE #-} TcInstDcls( tcInstDecls1 )
 import TcDeriv (DerivInfo)
-import TcEvidence  ( tcCoercionKind, isEmptyTcEvBinds )
-import TcUnify     ( checkConstraints )
 import TcHsType
+import ClsInst( AssocInstInfo(..) )
+import Inst( tcInstTyBinders )
 import TcMType
 import TysWiredIn ( unitTy )
 import TcType
@@ -64,7 +65,6 @@ import Outputable
 import Maybes
 import Unify
 import Util
-import Pair
 import SrcLoc
 import ListSetOps
 import DynFlags
@@ -380,8 +380,7 @@ TcTyCons are used for two distinct purposes
 
     Instead of trying, we just store the list of type variables to
     bring into scope, in the tyConScopedTyVars field of the TcTyCon.
-    These tyvars are brought into scope in kcTyClTyVars and
-    tcTyClTyVars, both in TcHsType.
+    These tyvars are brought into scope in TcHsType.bindTyClTyVars.
 
     In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather
     than just [TcTyVar]?  Consider these mutually-recursive decls
@@ -481,12 +480,11 @@ kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
 -- Kind check this group, kind generalize, and return the resulting local env
 -- This binds the TyCons and Classes of the group, but not the DataCons
 -- See Note [Kind checking for type and class decls]
--- Third return value is Nothing if the tycon be unsaturated; otherwise,
--- the arity
+-- and Note [Inferring kinds for type declarations]
 kcTyClGroup decls
   = do  { mod <- getModule
         ; traceTc "---- kcTyClGroup ---- {"
-            (text "module" <+> ppr mod $$ vcat (map ppr decls))
+                  (text "module" <+> ppr mod $$ vcat (map ppr decls))
 
           -- Kind checking;
           --    1. Bind kind variables for decls
@@ -494,33 +492,39 @@ kcTyClGroup decls
           --    3. Generalise the inferred kinds
           -- See Note [Kind checking for type and class decls]
 
-          -- Step 1: Bind kind variables for all decls
-        ; initial_tcs <- getInitialKinds decls
-        ; traceTc "kcTyClGroup: initial kinds" $
-          ppr_tc_kinds initial_tcs
+        ; let (cusk_decls, no_cusk_decls)
+                 = partition (hsDeclHasCusk . unLoc) decls
 
-         -- Step 2: Set extended envt, kind-check the decls
-         -- NB: the environment extension overrides the tycon
-         --     promotion-errors bindings
-         --     See Note [Type environment evolution]
+        ; poly_cusk_tcs <- getInitialKinds True cusk_decls
 
-        ; solveEqualities $
-          tcExtendKindEnvWithTyCons initial_tcs $
-          mapM_ kcLTyClDecl decls
+        ; mono_tcs
+            <- tcExtendKindEnvWithTyCons poly_cusk_tcs $
+               pushTcLevelM_   $  -- We are going to kind-generalise, so
+                                  -- unification variables in here must
+                                  -- be one level in
+               solveEqualities $
+               do {  -- Step 1: Bind kind variables for all decls
+                    mono_tcs <- getInitialKinds False no_cusk_decls
 
-        -- Step 3: skolemisation
-        -- Kind checking done for this group
-        -- Now we have to kind skolemise the flexis
-        ; candidates <- gather_quant_candidates initial_tcs
-        ; _ <- quantifyTyVars emptyVarSet candidates
-           -- We'll get the actual vars to quantify over later.
+                  ; traceTc "kcTyClGroup: initial kinds" $
+                    ppr_tc_kinds mono_tcs
 
-        -- Step 4: generalisation
+                    -- Step 2: Set extended envt, kind-check the decls
+                    -- NB: the environment extension overrides the tycon
+                    --     promotion-errors bindings
+                    --     See Note [Type environment evolution]
+                  ; tcExtendKindEnvWithTyCons mono_tcs $
+                    mapM_ kcLTyClDecl no_cusk_decls
+
+                  ; return mono_tcs }
+
+        -- Step 3: generalisation
         -- Finally, go through each tycon and give it its final kind,
         -- with all the required, specified, and inferred variables
         -- in order.
-        ; poly_tcs <- mapAndReportM generalise initial_tcs
+        ; poly_no_cusk_tcs <- mapAndReportM generaliseTcTyCon mono_tcs
 
+        ; let poly_tcs = poly_cusk_tcs ++ poly_no_cusk_tcs
         ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)
         ; return poly_tcs }
 
@@ -528,198 +532,215 @@ kcTyClGroup decls
     ppr_tc_kinds tcs = vcat (map pp_tc tcs)
     pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)
 
-    gather_quant_candidates :: [TcTyCon] -> TcM CandidatesQTvs
-    gather_quant_candidates tcs = mconcat <$> mapM gather1 tcs
+generaliseTcTyCon :: TcTyCon -> TcM TcTyCon
+generaliseTcTyCon tc
+  -- See Note [Required, Specified, and Inferred for types]
+  = setSrcSpan (getSrcSpan tc) $
+    addTyConCtxt tc $
+    do { let tc_name     = tyConName tc
+             tc_flav     = tyConFlavour tc
+             tc_res_kind = tyConResKind tc
+             tc_tvs      = tyConTyVars  tc
+             user_tyvars = tcTyConUserTyVars tc  -- ToDo: nuke
+
+             (scoped_tv_names, scoped_tvs) = unzip (tcTyConScopedTyVars tc)
+             -- NB: scoped_tvs includes both specified and required (tc_tvs)
+             -- ToDo: Is this a good idea?
+
+       -- Step 1: find all the variables we want to quantify over,
+       --         including Inferred, Specfied, and Required
+       ; dvs <- candidateQTyVarsOfKinds $
+                (tc_res_kind : map tyVarKind scoped_tvs)
+       ; tc_tvs      <- mapM zonkTcTyVarToTyVar tc_tvs
+       ; let full_dvs = dvs { dv_tvs = mkDVarSet tc_tvs }
+
+       -- Step 2: quantify, mainly meaning skolemise the free variables
+       ; qtkvs <- quantifyTyVars emptyVarSet full_dvs
+                  -- Returned 'qtkvs' are scope-sorted and skolemised
+
+       -- Step 3: find the final identity of the Specified and Required tc_tvs
+       -- (remember they all started as TyVarTvs).
+       -- They have been skolemised by quantifyTyVars.
+       ; scoped_tvs  <- mapM zonkTcTyVarToTyVar scoped_tvs
+       ; tc_tvs      <- mapM zonkTcTyVarToTyVar tc_tvs
+       ; tc_res_kind <- zonkTcType tc_res_kind
+
+       ; traceTc "Generalise kind pre" $
+         vcat [ text "tycon =" <+> ppr tc
+              , text "tc_tvs =" <+> pprTyVars tc_tvs
+              , text "scoped_tvs =" <+> pprTyVars scoped_tvs ]
+
+       -- Step 4: Find the Specified and Inferred variables
+       -- First, delete the Required tc_tvs from qtkvs; then
+       -- partition by whether they are scoped (if so, Specified)
+       ; let qtkv_set      = mkVarSet qtkvs
+             tc_tv_set     = mkVarSet tc_tvs
+             specified     = scopedSort $
+                             [ tv | tv <- scoped_tvs
+                                  , not (tv `elemVarSet` tc_tv_set)
+                                  , tv `elemVarSet` qtkv_set ]
+                             -- NB: maintain the L-R order of scoped_tvs
+             spec_req_set  = mkVarSet specified `unionVarSet` tc_tv_set
+             inferred      = filterOut (`elemVarSet` spec_req_set) qtkvs
+
+       -- Step 5: Make the TyConBinders.
+             dep_fv_set     = candidateKindVars dvs
+             inferred_tcbs  = mkNamedTyConBinders Inferred inferred
+             specified_tcbs = mkNamedTyConBinders Specified specified
+             required_tcbs  = map (mkRequiredTyConBinder dep_fv_set) tc_tvs
+
+       -- Step 6: Assemble the final list.
+             final_tcbs = concat [ inferred_tcbs
+                                 , specified_tcbs
+                                 , required_tcbs ]
+
+             scoped_tv_pairs = scoped_tv_names `zip` scoped_tvs
+
+       -- Step 7: Make the result TcTyCon
+             tycon = mkTcTyCon tc_name user_tyvars final_tcbs tc_res_kind
+                            scoped_tv_pairs
+                            True {- it's generalised now -}
+                            (tyConFlavour tc)
+
+       ; traceTc "Generalise kind" $
+         vcat [ text "tycon =" <+> ppr tc
+              , text "tc_tvs =" <+> pprTyVars tc_tvs
+              , text "tc_res_kind =" <+> ppr tc_res_kind
+              , text "scoped_tvs =" <+> pprTyVars scoped_tvs
+              , text "inferred =" <+> pprTyVars inferred
+              , text "specified =" <+> pprTyVars specified
+              , text "required_tcbs =" <+> ppr required_tcbs
+              , text "final_tcbs =" <+> ppr final_tcbs ]
+
+       -- Step 8: check for floating kind vars
+       -- See Note [Free-floating kind vars]
+       -- They are easily identified by the fact that they
+       -- have not been skolemised by quantifyTyVars
+       ; let floating_specified = filter isTyVarTyVar scoped_tvs
+       ; reportFloatingKvs tc_name tc_flav
+                           scoped_tvs floating_specified
+
+       -- Step 9: Check for duplicates
+       -- E.g. data SameKind (a::k) (b::k)
+       --      data T (a::k1) (b::k2) = MkT (SameKind a b)
+       -- Here k1 and k2 start as TyVarTvs, and get unified with each other
+       ; mapM_ report_sig_tv_err (findDupTyVarTvs scoped_tv_pairs)
+
+       -- Step 10: Check for validity.
+       -- We do this here because we're about to put the tycon into
+       -- the environment, and we don't want anything malformed in the
+       -- environment.
+       ; checkValidTelescope tycon
 
-    gather1 :: TcTyCon -> TcM CandidatesQTvs
-    gather1 tc
-      | tcTyConIsPoly tc  -- these don't need generalisation
-      = return mempty
+       ; return tycon }
+  where
+    report_sig_tv_err (n1, n2)
+      = setSrcSpan (getSrcSpan n2) $
+        addErrTc (text "Couldn't match" <+> quotes (ppr n1)
+                        <+> text "with" <+> quotes (ppr n2))
 
-      | otherwise
-      = do { tc_binders  <- zonkTyConBinders (tyConBinders tc)
-           ; tc_res_kind <- zonkTcType (tyConResKind tc)
+{- Note [Required, Specified, and Inferred for types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Each forall'd type variable in a type or kind is one of
 
-           ; let tvs = mkDVarSet $ map binderVar tc_binders
-                 kvs = tyCoVarsOfTypesDSet (tc_res_kind : map binderType tc_binders)
-                       `minusDVarSet` tvs
+  * Required: an argument must be provided at every call site
 
-           ; return (mempty { dv_kvs = kvs, dv_tvs = tvs }) }
+  * Specified: the argument can be inferred at call sites, but
+    may be instantiated with visible type/kind application
 
-    generalise :: TcTyCon -> TcM TcTyCon
-    generalise tc
-      | tcTyConIsPoly tc
-      = return tc  -- nothing to do here; we already have the final kind
-                   -- This is just an optimization; generalising is a no-op
+  * Inferred: the must be inferred at call sites; it
+    is unavailable for use with visible type/kind application.
 
-      | otherwise
-        -- See Note [Required, Specified, and Inferred for types]
-      = do {  -- Step 0: get the tyvars from the enclosing class (if any)
-             (all_class_tctvs, class_scoped_tvs) <- get_class_tvs tc
-
-              -- Step 1: gather all the free variables
-           ; tc_tvs          <- mapM zonkTcTyCoVarBndr (map binderVar (tyConBinders tc))
-           ; tc_res_kind     <- zonkTcType (tyConResKind tc)
-           ; scoped_tv_pairs <- zonkTyVarTyVarPairs (tcTyConScopedTyVars tc)
-
-           ; let all_fvs    = tyCoVarsOfTypesDSet (tc_res_kind : map tyVarKind tc_tvs)
-                 scoped_tvs = map snd scoped_tv_pairs
-
-           ; MASSERT( all ((== Required) . tyConBinderArgFlag) (tyConBinders tc) )
-
-             -- Step 2: Select out the Required arguments; that is, the tc_binders
-           ; let no_req_fvs = all_fvs `delDVarSetList` tc_tvs
-
-             -- Step 3: partition remaining variables into class variables and
-             -- local variables (matters only for associated types)
-                 (class_fvs, local_fvs)
-                   = partitionDVarSet (`elemDVarSet` all_class_tctvs) no_req_fvs
-
-             -- Step 4: For each set so far, use the set to select the scoped_tvs.
-             -- We take from the scoped_tvs to preserve order. These tvs will become
-             -- the Specified ones.
-                 class_specified = filter (`elemDVarSet` class_fvs) class_scoped_tvs
-                 local_specified = filter (`elemDVarSet` local_fvs) scoped_tvs
-
-             -- Step 5: Order the specified variables by ScopedSort
-             -- See Note [ScopedSort] in Type
-                 class_specified_sorted = scopedSort class_specified
-                 local_specified_sorted = scopedSort local_specified
-
-             -- Step 6: Remove the Specified ones from the fv sets. These are the
-             -- Inferred ones.
-                 class_inferred_set = class_fvs `delDVarSetList` class_specified_sorted
-                 local_inferred_set = local_fvs `delDVarSetList` local_specified_sorted
-
-                 class_inferred = dVarSetElemsWellScoped class_inferred_set
-                 local_inferred = dVarSetElemsWellScoped local_inferred_set
-
-             -- Step 7: Make the TyConBinders.
-                 class_inferred_tcbs  = mkNamedTyConBinders Inferred class_inferred
-                 class_specified_tcbs = mkNamedTyConBinders Specified class_specified_sorted
-                 local_inferred_tcbs  = mkNamedTyConBinders Inferred local_inferred
-                 local_specified_tcbs = mkNamedTyConBinders Specified local_specified_sorted
-
-                 mk_req_tcb tv
-                   | tv `elemDVarSet` all_fvs = mkNamedTyConBinder Required tv
-                   | otherwise                = mkAnonTyConBinder tv
-
-                 required_tcbs = map mk_req_tcb tc_tvs
-
-             -- Step 8: Assemble the final list.
-                 final_tcbs = concat [ class_inferred_tcbs
-                                     , class_specified_tcbs
-                                     , local_inferred_tcbs
-                                     , local_specified_tcbs
-                                     , required_tcbs ]
-
-             -- Step 9: Check for validity. We do this here because we're about to
-             -- put the tycon into the environment, and we don't want anything malformed
-             -- in the environment.
-           ; let user_tyvars = tcTyConUserTyVars tc
-           ; setSrcSpan (getSrcSpan tc) $
-             addTyConCtxt tc $
-             checkValidTelescope final_tcbs user_tyvars
-
-             -- Step 10: Make the result TcTyCon
-           ; let name = tyConName tc
-           ; traceTc "Generalise kind" $
-             vcat [ text "name =" <+> ppr name
-                  , text "all_class_tctvs =" <+> ppr all_class_tctvs
-                  , text "class_scoped_tvs =" <+> ppr class_scoped_tvs
-                  , text "tc_tvs =" <+> ppr tc_tvs
-                  , text "tc_res_kind =" <+> ppr tc_res_kind
-                  , text "scoped_tvs =" <+> ppr scoped_tvs
-                  , text "class_inferred_tcbs =" <+> ppr class_inferred_tcbs
-                  , text "class_specified_tcbs =" <+> ppr class_specified_tcbs
-                  , text "local_inferred_tcbs =" <+> ppr local_inferred_tcbs
-                  , text "local_specified_tcbs =" <+> ppr local_specified_tcbs
-                  , text "required_tcbs =" <+> ppr required_tcbs ]
-           ; return $ mkTcTyCon name user_tyvars final_tcbs tc_res_kind scoped_tv_pairs
-                                True {- it's generalised now -} (tyConFlavour tc) }
-
-    get_class_tvs :: TcTyCon -> TcM (DTyCoVarSet, [TcTyVar])
-        -- returns all tyConTyVars of the enclosing class, as well as its
-        -- scoped type variables. Both are zonked.
-    get_class_tvs at_tc
-      | Just class_tc <- tyConAssoc_maybe at_tc
-      = do { -- We can't just call tyConTyVars, because the enclosing class
-             -- hasn't been generalised yet
-             tc_binders  <- zonkTyConBinders (tyConBinders class_tc)
-           ; tc_res_kind <- zonkTcType (tyConResKind class_tc)
-           ; scoped_tvs  <- mapM zonkTcTyVarToTyVar (map snd (tcTyConScopedTyVars class_tc))
-
-           ; return ( tyCoVarsOfTypesDSet (tc_res_kind : map binderType tc_binders)
-                      `extendDVarSetList` tyConTyVars class_tc
-                    , scoped_tvs ) }
+Why have Inferred at all? Because we just can't make user-facing
+promises about the ordering of some variables. These might swizzle
+around even between minor released. By forbidding visible type
+application, we ensure users aren't caught unawares.
 
-      | otherwise
-      = return (emptyDVarSet, [])
+Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.
 
-{- Note [Required, Specified, and Inferred for types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have some design choices in how we classify the tyvars bound
-in a type declaration. (Here, I use "type" to refer to any TyClDecl.)
-Much of the debate is memorialized in #15743. This Note documents
-the final conclusion.
-
-First, a reminder:
-  * a Required argument is one that must be provided at every call site
-  * a Specified argument is one that can be inferred at call sites, but
-    may be instantiated with visible type application
-  * an Inferred argument is one that must be inferred at call sites; it
-    is unavailable for use with visible type application.
-
-Why have Inferred at all? Because we just can't make user-facing promises
-about the ordering of some variables. These might swizzle around even between
-minor released. By forbidding visible type application, we ensure users
-aren't caught unawares. See also
-Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.
-
-When inferring the ordering of variables (that is, for those
-variables that he user has not specified the order with an explicit `forall`)
-we use the following order:
-
- 1. Inferred variables from an enclosing class (associated types only)
- 2. Specified variables from an enclosing class (associated types only)
- 3. Inferred variables not from an enclosing class
- 4. Specified variables not from an enclosing class
- 5. Required variables before a top-level ::
- 6. All variables after a top-level ::
+The question for this Note is this:
+   given a TyClDecl, how are its quantified type variables classified?
+Much of the debate is memorialized in #15743.
+
+Here is our design choice. When inferring the ordering of variables
+for a TyCl declaration (that is, for those variables that he user
+has not specified the order with an explicit `forall`), we use the
+following order:
+
+ 1. Inferred variables
+ 2. Specified variables; in the left-to-right order in which
+    the user wrote them, modified by scopedSort (see below)
+    to put them in depdendency order.
+ 3. Required variables before a top-level ::
+ 4. All variables after a top-level ::
 
 If this ordering does not make a valid telescope, we reject the definition.
 
-This idea is implemented in the generalise function within kcTyClGroup (for
-declarations without CUSKs), and in kcLHsQTyVars (for declarations with
-CUSKs). Note that neither definition worries about point (6) above, as this
+Example:
+  data SameKind :: k -> k -> *
+  data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)
+
+For X:
+  - a, c, d, x are Required; they are explicitly listed by the user
+    as the positional arguments of Bad
+  - b is Specified; it appears explicitly in a kind signature
+  - k, the kind of a, is Inferred; it is not mentioned explicitly at all
+
+Putting variables in the order Inferred, Specified, Required
+gives us this telescope:
+  Inferred:  k
+  Specified: b : Proxy a
+  Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d)
+
+But this order is ill-scoped, because b's kind mentions a, which occurs
+after b in the telescope. So we reject Bad.
+
+Associated types
+~~~~~~~~~~~~~~~~
+For associated types everything above is determined by the
+associated-type declaration alone, ignoring the class header.
+Here is an example (Trac #15592)
+  class C (a :: k) b where
+    type F (x :: b a)
+
+In the kind of C, 'k' is Specified.  But what about F?
+In the kind of F,
+
+ * Should k be Inferred or Specified?  It's Specified for C,
+   but not mentioned in F's declaration.
+
+ * In which order should the Specified variables a and b occur?
+   It's clearly 'a' then 'b' in C's declaration, but the L-R ordering
+   in F's declaration is 'b' then 'a'.
+
+In both cases we make the choice by looking at F's declaration alone,
+so it gets the kind
+   F :: forall {k}. forall b a. b a -> Type
+
+How it works
+~~~~~~~~~~~~
+These design choices are implemented by two completely different code
+paths for
+
+  * Declarations with a compulete user-specified kind signature (CUSK)
+    Handed by the CUSK case of kcLHsQTyVars.
+
+  * Declarations without a CUSK are handled by kcTyClDecl; see
+    Note [Inferring kinds for type declarations].
+
+Note that neither code path worries about point (4) above, as this
 is nicely handled by not mangling the res_kind. (Mangling res_kinds is done
-*after* all this stuff, in tcDataDefn's call to tcDataKindSig.) We can
-easily tell Inferred apart from Specified by looking at the scoped tyvars;
-Specified are always included there.
-
-One other small open question here: how to classify variables from an
-enclosing class? Here is an example:
-
-  class C (a :: k) where
-    type F a
-
-In the kind of F, should k be Inferred or Specified? Currently, we mark
-it as Specified, as we can commit to an ordering, based on the ordering
-of class variables in the enclosing class declaration. If k were not mentioned
-in the class head, then it would be Inferred. The alternative to this
-approach is to make the Inferred/Specified distinction locally, by just
-looking at the declaration for F. This lowers the availability of type
-application, but makes the reasoning more local. However, this alternative
-also disagrees with the treatment for methods, where all class variables
-are Specified, regardless of whether or not the variable is mentioned in the
-method type.
-
-A few points of motivation for the ordering above:
-
-* We put the class variables before the local variables in a nod to the
-  treatment for class methods, where class variables (and the class constraint)
-  come first. While this is an unforced design decision, it never rejects
-  more declarations, as class variables can never depend on local variables.
+*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.)
+
+We can tell Inferred apart from Specified by looking at the scoped
+tyvars; Specified are always included there.
+
+Design alternatives
+~~~~~~~~~~~~~~~~~~~
+
+* For associated types we considered putting the class variables
+  before the local variables, in a nod to the treatment for class
+  methods. But it got too compilicated; see Trac #15592, comment:21ff.
 
 * We rigidly require the ordering above, even though we could be much more
   permissive. Relevant musings are at
@@ -736,11 +757,94 @@ A few points of motivation for the ordering above:
   we can be sure that inference wouldn't change between versions. However,
   would users be able to predict it? That I cannot answer.
 
-Test cases (and tickets) relevant to these design decisions:
+Test cases (and tickets) relevant to these design decisions
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   T15591*
   T15592*
   T15743*
 
+Note [Inferring kinds for type declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This note deals with /inference/ for type declarations
+that do not have a CUSK.  Consider
+  data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x)
+  data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y)
+
+We do kind inference as follows:
+
+* Step 1: Assign initial monomorophic kinds to S, T
+          S :: kk1 -> * -> kk2 -> *
+          T :: kk3 -> * -> kk4 -> *
+  Here kk1 etc are TyVarTvs: that is, unification variables that
+  are allowed to unify only with other type variables. See
+  Note [Signature skolems] in TcType
+
+* Step 2: Extend the environment with a TcTyCon for S and T, with
+  these monomophic kinds.  Now kind-check the declarations, and solve
+  the resulting equalities.  The goal here is to discover constraints
+  on all these unification variables.
+
+  Here we find that kk1 := kk3, and kk2 := kk4.
+
+  This is why we can't use skolems for kk1 etc; they have to
+  unify with each other.
+
+* Step 3. Generalise each TyCon in turn (generaliseTcTyCon).
+  We find the free variables of the kind, skolemise them,
+  sort them out into Inferred/Required/Specified (see the above
+  Note [Required, Specified, and Inferred for types]),
+  and perform some validity checks.
+
+  This makes the utterly-final TyConBinders for the TyCon
+
+  All this is very similar at the level of terms: see TcBinds
+  Note [Quantified variables in partial type signatures]
+
+* Step 4.  Extend the type environment with a TcTyCon for S and T, now
+  with their utterly-final polymorphic kinds (needed for recursive
+  occurrences of S, T).  Now typecheck the declarations, and build the
+  final AlgTyCOn for S and T resp.
+
+The first three steps are in kcTyClGroup;
+the fourth is in tcTyClDecls.
+
+There are some wrinkles
+
+* Do not default TyVarTvs.  We always want to kind-generalise over
+  TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is
+  not allowed to unify with a type; it must stand for a type
+  variable. Hence the check in TcSimplify.defaultTyVarTcS, and
+  TcMType.defaultTyVar.  Here's another example (Trac #14555):
+     data Exp :: [TYPE rep] -> TYPE rep -> Type where
+        Lam :: Exp (a:xs) b -> Exp xs (a -> b)
+  We want to kind-generalise over the 'rep' variable.
+  Trac #14563 is another example.
+
+* Duplicate type variables. Consider Trac #11203
+    data SameKind :: k -> k -> *
+    data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)
+  Here we will unify k1 with k2, but this time doing so is an error,
+  because k1 and k2 are bound in the same declaration.
+
+  We spot this during validity checking (findDupTyVarTvs),
+  in generaliseTcTyCon.
+
+* Required arguments.  Even the Required arguments should be made
+  into TyVarTvs, not skolems.  Consider
+    data T k (a :: k)
+  Here, k is a Required, dependent variable. For uniformity, it is helpful
+  to have k be a TyVarTv, in parallel with other dependent variables.
+
+* Duplicate skolemisation is expected.  When generalising in Step 3,
+  we may find that one of the variables we want to quantify has
+  already been skolemised.  For example, suppose we have already
+  generalise S. When we come to T we'll find that kk1 (now the same as
+  kk3) has already been skolemised.
+
+  That's fine -- but it means that
+    a) when collecting quantification candidates, in
+       candidateQTyVarsOfKind, we must collect skolems
+    b) quantifyTyVars should be a no-op on such a skolem
 -}
 
 --------------
@@ -779,13 +883,17 @@ mk_prom_err_env decl
     -- Works for family declarations too
 
 --------------
-getInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
+getInitialKinds :: Bool -> [LTyClDecl GhcRn] -> TcM [TcTyCon]
 -- Returns a TcTyCon for each TyCon bound by the decls,
 -- each with its initial kind
 
-getInitialKinds decls = concatMapM (addLocM getInitialKind) decls
+getInitialKinds cusk decls
+  = do { traceTc "getInitialKinds {" empty
+       ; tcs <- concatMapM (addLocM (getInitialKind cusk)) decls
+       ; traceTc "getInitialKinds done }" empty
+       ; return tcs }
 
-getInitialKind :: TyClDecl GhcRn -> TcM [TcTyCon]
+getInitialKind :: Bool -> TyClDecl GhcRn -> TcM [TcTyCon]
 -- Allocate a fresh kind variable for each TyCon and Class
 -- For each tycon, return a TcTyCon with kind k
 -- where k is the kind of tc, derived from the LHS
@@ -800,11 +908,11 @@ getInitialKind :: TyClDecl GhcRn -> TcM [TcTyCon]
 --
 -- No family instances are passed to getInitialKinds
 
-getInitialKind decl@(ClassDecl { tcdLName = (dL->L _ name)
-                               , tcdTyVars = ktvs
-                               , tcdATs = ats })
-  = do { let cusk = hsDeclHasCusk decl
-       ; tycon <- kcLHsQTyVars name ClassFlavour cusk ktvs $
+getInitialKind cusk
+    (ClassDecl { tcdLName = dL->L _ name
+               , tcdTyVars = ktvs
+               , tcdATs = ats })
+  = do { tycon <- kcLHsQTyVars name ClassFlavour cusk ktvs $
                   return constraintKind
        ; let parent_tv_prs = tcTyConScopedTyVars tycon
             -- See Note [Don't process associated types in kcLHsQTyVars]
@@ -812,30 +920,29 @@ getInitialKind decl@(ClassDecl { tcdLName = (dL->L _ name)
                       getFamDeclInitialKinds (Just tycon) ats
        ; return (tycon : inner_tcs) }
 
-getInitialKind decl@(DataDecl { tcdLName = (dL->L _ name)
-                              , tcdTyVars = ktvs
-                              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
-                                                         , dd_ND = new_or_data } })
-  = do  { tycon <-
-           kcLHsQTyVars name (newOrDataToFlavour new_or_data)
-                        (hsDeclHasCusk decl) ktvs $
-           case m_sig of
-             Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig
-             Nothing   -> return liftedTypeKind
-        ; return [tycon] }
-
-getInitialKind (FamDecl { tcdFam = decl })
+getInitialKind cusk
+    (DataDecl { tcdLName = dL->L _ name
+              , tcdTyVars = ktvs
+              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
+                                         , dd_ND = new_or_data } })
+  = do  { let flav = newOrDataToFlavour new_or_data
+        ; tc <- kcLHsQTyVars name flav cusk ktvs $
+                case m_sig of
+                   Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig
+                   Nothing   -> return liftedTypeKind
+        ; return [tc] }
+
+getInitialKind (FamDecl { tcdFam = decl })
   = do { tc <- getFamDeclInitialKind Nothing decl
        ; return [tc] }
 
-getInitialKind decl@(SynDecl { tcdLName = (dL->L _ name)
+getInitialKind cusk (SynDecl { tcdLName = dL->L _ name
                              , tcdTyVars = ktvs
                              , tcdRhs = rhs })
-  = do  { tycon <- kcLHsQTyVars name TypeSynonymFlavour (hsDeclHasCusk decl)
-                                ktvs $
-            case kind_annotation rhs of
-              Nothing -> newMetaKindVar
-              Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig
+  = do  { tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $
+                   case kind_annotation rhs of
+                     Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig
+                     Nothing   -> newMetaKindVar
         ; return [tycon] }
   where
     -- Keep this synchronized with 'hsDeclHasCusk'.
@@ -844,8 +951,8 @@ getInitialKind decl@(SynDecl { tcdLName = (dL->L _ name)
         HsKindSig _ _ k   -> Just k
         _                 -> Nothing
 
-getInitialKind (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind"
-getInitialKind (XTyClDecl _) = panic "getInitialKind"
+getInitialKind (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind"
+getInitialKind (XTyClDecl _) = panic "getInitialKind"
 
 ---------------------------------
 getFamDeclInitialKinds
@@ -888,10 +995,6 @@ getFamDeclInitialKind _ (XFamilyDecl _) = panic "getFamDeclInitialKind"
 kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
   -- See Note [Kind checking for type and class decls]
 kcLTyClDecl (dL->L loc decl)
-  | hsDeclHasCusk decl  -- See Note [Skip decls with CUSKs in kcLTyClDecl]
-  = traceTc "kcTyClDecl skipped due to cusk:" (ppr tc_name)
-
-  | otherwise
   = setSrcSpan loc $
     tcAddDeclCtxt decl $
     do { traceTc "kcTyClDecl {" (ppr tc_name)
@@ -919,27 +1022,24 @@ kcTyClDecl (DataDecl { tcdLName    = (dL->L _ name)
     --    (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it