Initial kind strategy

2 files changed, 135 insertions, 134 deletions

diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 50263f7fc7..b2c3bcd5aa 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -38,8 +38,8 @@ module TcHsType (
 
         -- Kind-checking types
         -- No kind generalisation, no checkValidType
+        InitialKindStrategy(..),
         kcDeclHeader,
-        kcInferDeclHeader,
         tcNamedWildCardBinders,
         tcHsLiftedType,   tcHsOpenType,
         tcHsLiftedTypeNC, tcHsOpenTypeNC,
@@ -1790,12 +1790,26 @@ newWildTyVar
 *                                                                      *
 ********************************************************************* -}
 
-{- Note [kcDeclHeader vs kcInferDeclHeader]
+data InitialKindStrategy
+  = InitialKindCheck (Maybe Kind)
+  | InitialKindInfer
+
+kcDeclHeader
+  :: InitialKindStrategy
+  -> Name              -- ^ of the thing being checked
+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
+  -> LHsQTyVars GhcRn  -- ^ Binders in the header
+  -> TcM ContextKind   -- ^ The result kind
+  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon
+kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig
+kcDeclHeader InitialKindInfer = kcInferDeclHeader
+
+{- Note [kcCheckDeclHeader vs kcInferDeclHeader]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-kcDeclHeader and kcInferDeclHeader are responsible for getting the initial kind
+kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind
 of a type constructor.
 
-* kcDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that
+* kcCheckDeclHeader: the TyCon has a standalone kind signature or 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.
 
@@ -1807,26 +1821,24 @@ of a type constructor.
 -}
 
 ------------------------------
-kcDeclHeader
-  :: Name              -- ^ of the thing being checked
-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
-  -> Maybe Kind        -- ^  Just sig  <=>  Standalone kind signature, fully zonked! (zonkTcTypeToType)
+kcCheckDeclHeader
+  :: Maybe Kind        -- ^  Just sig  <=>  Standalone kind signature, fully zonked! (zonkTcTypeToType)
                        --    Nothing   <=>  Complete user-specified kind (CUSK)
+  -> Name              -- ^ of the thing being checked
+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
   -> LHsQTyVars GhcRn  -- ^ Binders in the header
-  -> Maybe (TcM Kind)  -- ^ The result kind
+  -> TcM ContextKind   -- ^ The result kind
   -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon
-kcDeclHeader name flav msig ktvs kc_res_ki =
-  case msig of
-    Just sig -> kcDeclHeader_sig  name flav sig ktvs kc_res_ki
-    Nothing  -> kcDeclHeader_cusk name flav     ktvs kc_res_ki
+kcCheckDeclHeader (Just sig) = kcCheckDeclHeader_sig sig
+kcCheckDeclHeader Nothing    = kcCheckDeclHeader_cusk
 
-kcDeclHeader_cusk
+kcCheckDeclHeader_cusk
   :: Name              -- ^ of the thing being checked
   -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
   -> LHsQTyVars GhcRn  -- ^ Binders in the header
-  -> Maybe (TcM Kind)  -- ^ The result kind
+  -> TcM ContextKind   -- ^ The result kind
   -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon
-kcDeclHeader_cusk name flav
+kcCheckDeclHeader_cusk name flav
               (HsQTvs { hsq_ext = kv_ns
                       , hsq_explicit = hs_tvs }) kc_res_ki
   -- CUSK case
@@ -1837,9 +1849,7 @@ kcDeclHeader_cusk name flav
               solveEqualities                             $
               bindImplicitTKBndrs_Q_Skol kv_ns            $
               bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $
-              case kc_res_ki of
-                Nothing -> return liftedTypeKind
-                Just kc -> kc
+              newExpectedKind =<< kc_res_ki
 
            -- Now, because we're in a CUSK,
            -- we quantify over the mentioned kind vars
@@ -1879,7 +1889,7 @@ kcDeclHeader_cusk name flav
          -- doesn't work, we catch it here, before an error cascade
        ; checkTyConTelescope tycon
 
-       ; traceTc "kcDeclHeader_cusk " $
+       ; traceTc "kcCheckDeclHeader_cusk " $
          vcat [ text "name" <+> ppr name
               , text "kv_ns" <+> ppr kv_ns
               , text "hs_tvs" <+> ppr hs_tvs
@@ -1898,7 +1908,7 @@ kcDeclHeader_cusk name flav
   where
     ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind
               | otherwise            = AnyKind
-kcDeclHeader_cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec
+kcCheckDeclHeader_cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec
 
 -- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and
 -- other kinds).
@@ -1908,11 +1918,11 @@ kcInferDeclHeader
   :: Name              -- ^ of the thing being checked
   -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
   -> LHsQTyVars GhcRn
-  -> TcM Kind          -- ^ The result kind
+  -> TcM ContextKind   -- ^ The result kind
   -> TcM TcTyCon       -- ^ A suitably-kinded non-generalized TcTyCon
 kcInferDeclHeader name flav
               (HsQTvs { hsq_ext = kv_ns
-                      , hsq_explicit = hs_tvs }) thing_inside
+                      , hsq_explicit = hs_tvs }) kc_res_ki
   -- No standalane kind signature and no CUSK.
   -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls
   = do { (scoped_kvs, (tc_tvs, res_kind))
@@ -1920,7 +1930,7 @@ kcInferDeclHeader name flav
            -- See Note [Inferring kinds for type declarations] in TcTyClsDecls
            <- bindImplicitTKBndrs_Q_Tv kv_ns            $
               bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $
-              thing_inside
+              newExpectedKind =<< kc_res_ki
               -- Why "_Tv" not "_Skol"? See third wrinkle in
               -- Note [Inferring kinds for type declarations] in TcTyClsDecls,
 
@@ -1958,15 +1968,15 @@ kcInferDeclHeader name flav
 kcInferDeclHeader _ _ (XLHsQTyVars nec) _ = noExtCon nec
 
 -- | Kind-check a declaration header against a standalone kind signature.
--- See Note [Arity inference in kcDeclHeader_sig]
-kcDeclHeader_sig
-  :: Name              -- ^ of the thing being checked
+-- See Note [Arity inference in kcCheckDeclHeader_sig]
+kcCheckDeclHeader_sig
+  :: Kind              -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType)
+  -> Name              -- ^ of the thing being checked
   -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
-  -> Kind              -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType)
   -> LHsQTyVars GhcRn  -- ^ Binders in the header
-  -> Maybe (TcM Kind)  -- ^ The result kind
+  -> TcM ContextKind   -- ^ The result kind
   -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon
-kcDeclHeader_sig name flav kisig ktvs kc_res_ki =
+kcCheckDeclHeader_sig kisig name flav ktvs kc_res_ki =
   addTyConFlavCtxt name flav $
     pushTcLevelM_ $
     solveEqualities $  -- #16687
@@ -2020,7 +2030,10 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki =
         --               ^^^^^^^^^
         -- We do it here because at this point the environment has been
         -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.
-        m_res_ki <- sequenceA @Maybe kc_res_ki
+        m_res_ki <- kc_res_ki >>= \ctx_k ->
+          case ctx_k of
+            AnyKind -> return Nothing
+            _ -> Just <$> newExpectedKind ctx_k
 
         -- Step 2: split off invisible binders.
         -- For example:
@@ -2029,7 +2042,7 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki =
         --   type family F
         --
         -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'?
-        -- See Note [Arity inference in kcDeclHeader_sig]
+        -- See Note [Arity inference in kcCheckDeclHeader_sig]
         let (invis_binders, r_ki) = split_invis kisig' m_res_ki
 
         -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders.
@@ -2043,7 +2056,7 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki =
         --
         -- Here we unify   Maybe k ~ Maybe j
         whenIsJust m_res_ki $ \res_ki ->
-          discardResult $ -- See Note [discardResult in kcDeclHeader_sig]
+          discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]
           unifyKind Nothing r_ki res_ki
 
         -- Zonk the implicitly quantified variables.
@@ -2054,7 +2067,7 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki =
             all_tv_prs = implicit_tv_prs ++ explicit_tv_prs
             tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav
 
-        traceTc "kcDeclHeader_sig done:" $ vcat
+        traceTc "kcCheckDeclHeader_sig done:" $ vcat
           [ text "tyConName = " <+> ppr (tyConName tc)
           , text "kisig =" <+> debugPprType kisig
           , text "tyConKind =" <+> debugPprType (tyConKind tc)
@@ -2149,7 +2162,7 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki =
         UserTyVar _ _ -> return ()
         KindedTyVar _ v v_hs_ki -> do
           v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki
-          discardResult $ -- See Note [discardResult in kcDeclHeader_sig]
+          discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]
             unifyKind (Just (HsTyVar noExtField NotPromoted v))
                       (tyBinderType tb)
                       v_ki
@@ -2157,7 +2170,7 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki =
 
     -- Split the invisible binders that should become a part of 'tyConBinders'
     -- rather than 'tyConResKind'.
-    -- See Note [Arity inference in kcDeclHeader_sig]
+    -- See Note [Arity inference in kcCheckDeclHeader_sig]
     split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind)
     split_invis sig_ki Nothing =
       -- instantiate all invisible binders
@@ -2173,7 +2186,7 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki =
 data ZippedBinder =
   ZippedBinder TyBinder (Maybe (LHsTyVarBndr GhcRn))
 
--- See Note [Arity inference in kcDeclHeader_sig]
+-- See Note [Arity inference in kcCheckDeclHeader_sig]
 zipBinders
   :: Kind                      -- kind signature
   -> [LHsTyVarBndr GhcRn]      -- user-written binders
@@ -2207,9 +2220,9 @@ tooManyBindersErr ki bndrs =
    hang (text "but extra binders found:")
       4 (fsep (map ppr bndrs))
 
-{- Note [Arity inference in kcDeclHeader_sig]
+{- Note [Arity inference in kcCheckDeclHeader_sig]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given a kind signature 'kisig' and a declaration header, kcDeclHeader_sig
+Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig
 verifies that the declaration conforms to the signature. The end result is a
 TcTyCon 'tc' such that:
 
@@ -2246,7 +2259,7 @@ This difference determines the arity:
 
 That is, the arity of S1 is 0, while the arity of S2 is 2.
 
-'kcDeclHeader_sig' needs to infer the desired arity to split the standalone
+'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone
 kind signature into binders and the result kind. It does so in two rounds:
 
 1. zip user-written binders (vis_tcbs)
@@ -2317,7 +2330,7 @@ The resulting arity of G is 3+1=4. (length vis_tcbs = 3,
 
 -}
 
-{- Note [discardResult in kcDeclHeader_sig]
+{- Note [discardResult in kcCheckDeclHeader_sig]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We use 'unifyKind' to check inline kind annotations in declaration headers
 against the signature.
@@ -2454,7 +2467,7 @@ Then `a` first appears /after/ `f`, so the kind of `T2` should be:
 
   T2 :: forall f a. f a -> Type
 
-In order to make this distinction, we need to know (in kcDeclHeader) which
+In order to make this distinction, we need to know (in kcCheckDeclHeader) which
 type variables have been bound by the parent class (if there is one). With
 the class-bound variables in hand, we can ensure that we always quantify
 these first.
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 8883bd8c1b..02d2c62631 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -487,9 +487,9 @@ to Note [Single function non-recursive binding special-case]:
 Unfortunately this requires reworking a bit of the code in
 'kcLTyClDecl' so I've decided to punt unless someone shouts about it.
 
-Note [Don't process associated types in kcInferDeclHeader]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Previously, we processed associated types in the thing_inside in kcInferDeclHeader,
+Note [Don't process associated types in getInitialKind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously, we processed associated types in the thing_inside in getInitialKind,
 but this was wrong -- we want to do ATs sepearately.
 The consequence for not doing it this way is #15142:
 
@@ -786,7 +786,7 @@ These design choices are implemented by two completely different code
 paths for
 
   * Declarations with a standalone kind signature or a complete user-specified
-    kind signature (CUSK). Handed by the kcDeclHeader.
+    kind signature (CUSK). Handed by the kcCheckDeclHeader.
 
   * Declarations without a kind signature (standalone or CUSK) are handled by
     kcInferDeclHeader; see Note [Inferring kinds for type declarations].
@@ -1016,11 +1016,24 @@ inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
 
 inferInitialKinds decls
   = do { traceTc "inferInitialKinds {" empty
-       ; tcs <- concatMapM (addLocM inferInitialKind) decls
+       ; tcs <- concatMapM infer_initial_kind decls
        ; traceTc "inferInitialKinds done }" empty
        ; return tcs }
+  where
+    infer_initial_kind = addLocM (getInitialKind InitialKindInfer)
+
+-- Check type/class declarations against their standalone kind signatures or
+-- CUSKs, producing a generalized TcTyCon for each.
+checkInitialKinds :: [(LTyClDecl GhcRn, Maybe Kind)] -> TcM [TcTyCon]
+checkInitialKinds = concatMapM check_initial_kind
+  where
+    check_initial_kind (dL -> L l d, msig) =
+      setSrcSpan l (getInitialKind (InitialKindCheck msig) d)
+
+-- | Get the initial kind of a TyClDecl, either generalized or non-generalized,
+-- depending on the InitialKindStrategy.
+getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]
 
-inferInitialKind :: 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
@@ -1033,43 +1046,72 @@ inferInitialKind :: TyClDecl GhcRn -> TcM [TcTyCon]
 --   * The kind signatures on type-variable binders
 --   * The result kinds signature on a TyClDecl
 --
--- No family instances are passed to inferInitialKinds
-
-inferInitialKind
+-- No family instances are passed to checkInitialKinds/inferInitialKinds
+getInitialKind strategy
     (ClassDecl { tcdLName = dL->L _ name
                , tcdTyVars = ktvs
                , tcdATs = ats })
-  = do { tycon <- kcInferDeclHeader name ClassFlavour ktvs $
-                  return constraintKind
-       ; let parent_tv_prs = tcTyConScopedTyVars tycon
-            -- See Note [Don't process associated types in kcInferDeclHeader]
+  = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $
+                return (TheKind constraintKind)
+       ; let parent_tv_prs = tcTyConScopedTyVars cls
+            -- See Note [Don't process associated types in getInitialKind]
        ; inner_tcs <-
            tcExtendNameTyVarEnv parent_tv_prs $
-           mapM (addLocM (get_fam_decl_initial_kind (Just tycon))) ats
-       ; return (tycon : inner_tcs) }
+           mapM (addLocM (getAssocFamInitialKind cls)) ats
+       ; return (cls : inner_tcs) }
+  where
+    getAssocFamInitialKind cls =
+      case strategy of
+        InitialKindInfer -> get_fam_decl_initial_kind (Just cls)
+        InitialKindCheck _ -> check_initial_kind_assoc_fam cls
 
-inferInitialKind
+getInitialKind strategy
     (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 <- kcInferDeclHeader name flav ktvs $
+              ctxt = DataKindCtxt name
+        ; tc <- kcDeclHeader strategy name flav ktvs $
                 case m_sig of
-                  Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig
+                  Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
                   Nothing -> dataDeclDefaultResultKind new_or_data
         ; return [tc] }
 
-inferInitialKind (FamDecl { tcdFam = decl })
+getInitialKind InitialKindInfer (FamDecl { tcdFam = decl })
   = do { tc <- get_fam_decl_initial_kind Nothing decl
        ; return [tc] }
 
-inferInitialKind (SynDecl { tcdLName = dL->L _ name, tcdTyVars = ktvs })
-  = do  { tc <- kcInferDeclHeader name TypeSynonymFlavour ktvs newMetaKindVar
-        ; return [tc] }
+getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam =
+  FamilyDecl { fdLName     = unLoc -> name
+             , fdTyVars    = ktvs
+             , fdResultSig = unLoc -> resultSig
+             , fdInfo      = info } } )
+  = do { let flav = getFamFlav Nothing info
+             ctxt = TyFamResKindCtxt name
+       ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $
+               case famResultKindSignature resultSig of
+                 Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
+                 Nothing -> return AnyKind
+       ; return [tc] }
 
-inferInitialKind (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec
-inferInitialKind (XTyClDecl nec) = noExtCon nec
+getInitialKind strategy
+    (SynDecl { tcdLName = dL->L _ name
+             , tcdTyVars = ktvs
+             , tcdRhs = rhs })
+  = do { let ctxt = TySynKindCtxt name
+       ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $
+               case strategy of
+                 InitialKindInfer -> return AnyKind
+                 InitialKindCheck _ ->
+                   case hsTyKindSig rhs of
+                     Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
+                     Nothing -> return AnyKind
+       ; return [tc] }
+
+getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec
+getInitialKind _ (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec
+getInitialKind _ (XTyClDecl nec) = noExtCon nec
 
 get_fam_decl_initial_kind
   :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls
@@ -1080,76 +1122,20 @@ get_fam_decl_initial_kind mb_parent_tycon
                , fdTyVars    = ktvs
                , fdResultSig = (dL->L _ resultSig)
                , fdInfo      = info }
-  = kcInferDeclHeader name flav ktvs $
+  = kcDeclHeader InitialKindInfer name flav ktvs $
     case resultSig of
-      KindSig _ ki                              -> tcLHsKindSig ctxt ki
-      TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki
+      KindSig _ ki                              -> TheKind <$> tcLHsKindSig ctxt ki
+      TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki
       _ -- open type families have * return kind by default
-        | tcFlavourIsOpen flav              -> return liftedTypeKind
+        | tcFlavourIsOpen flav              -> return (TheKind liftedTypeKind)
                -- closed type families have their return kind inferred
                -- by default
-        | otherwise                         -> newMetaKindVar
+        | otherwise                         -> return AnyKind
   where
     flav = getFamFlav mb_parent_tycon info
     ctxt = TyFamResKindCtxt name
 get_fam_decl_initial_kind _ (XFamilyDecl nec) = noExtCon nec
 
--- Check type/class declarations against their standalone kind signatures or
--- CUSKs, producing a generalized TcTyCon for each.
-checkInitialKinds :: [(LTyClDecl GhcRn, Maybe Kind)] -> TcM [TcTyCon]
-checkInitialKinds = concatMapM check_initial_kind
-  where
-    check_initial_kind (dL -> L l d, msig) =
-      setSrcSpan l (checkInitialKind msig d)
-
-checkInitialKind :: Maybe Kind -> TyClDecl GhcRn -> TcM [TcTyCon]
-checkInitialKind msig
-    (ClassDecl { tcdLName = dL->L _ name
-               , tcdTyVars = ktvs
-               , tcdATs = ats })
-  = do { cls <- kcDeclHeader name ClassFlavour msig ktvs $
-                Just $ return constraintKind
-       ; let parent_tv_prs = tcTyConScopedTyVars cls
-            -- See Note [Don't process associated types in kcInferDeclHeader]
-       ; inner_tcs <-
-           tcExtendNameTyVarEnv parent_tv_prs $
-           mapM (addLocM (check_initial_kind_assoc_fam cls)) ats
-       ; return (cls : inner_tcs) }
-checkInitialKind msig
-    (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
-             ctxt = DataKindCtxt name
-       ; tc <- kcDeclHeader name flav msig ktvs $
-               Just $ case m_sig of
-                  Just ksig -> tcLHsKindSig ctxt ksig
-                  Nothing   -> dataDeclDefaultResultKind new_or_data
-       ; return [tc] }
-checkInitialKind msig (FamDecl { tcdFam =
-  FamilyDecl { fdLName     = unLoc -> name
-             , fdTyVars    = ktvs
-             , fdResultSig = unLoc -> resultSig
-             , fdInfo      = info } } )
-  = do { let flav = getFamFlav Nothing info
-             ctxt = TyFamResKindCtxt name
-       ; tc <- kcDeclHeader name flav msig ktvs $
-               fmap (tcLHsKindSig ctxt) (famResultKindSignature resultSig)
-       ; return [tc] }
-checkInitialKind msig
-    (SynDecl { tcdLName = dL->L _ name
-             , tcdTyVars = ktvs
-             , tcdRhs = rhs })
-  = do  { let ctxt = TySynKindCtxt name
-        ; tc <- kcDeclHeader name TypeSynonymFlavour msig ktvs $
-                fmap (tcLHsKindSig ctxt) (hsTyKindSig rhs)
-        ; return [tc] }
-
-checkInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec
-checkInitialKind _ (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec
-checkInitialKind _ (XTyClDecl nec) = noExtCon nec
-
 -- See Note [Standalone kind signatures for associated types]
 check_initial_kind_assoc_fam
   :: TcTyCon -- parent class
@@ -1161,8 +1147,10 @@ check_initial_kind_assoc_fam cls
     , fdTyVars    = ktvs
     , fdResultSig = unLoc -> resultSig
     , fdInfo      = info }
-  = kcDeclHeader name flav Nothing ktvs $
-    fmap (tcLHsKindSig ctxt) (famResultKindSignature resultSig)
+  = kcDeclHeader (InitialKindCheck Nothing) name flav ktvs $
+    case famResultKindSignature resultSig of
+      Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
+      Nothing -> return (TheKind liftedTypeKind)
   where
     ctxt = TyFamResKindCtxt name
     flav = getFamFlav (Just cls) info
@@ -1202,13 +1190,13 @@ have before standalone kind signatures:
 -}
 
 -- See Note [Data declaration default result kind]
-dataDeclDefaultResultKind :: NewOrData -> TcM Kind
+dataDeclDefaultResultKind :: NewOrData -> TcM ContextKind
 dataDeclDefaultResultKind new_or_data = do
   -- See Note [Implementation of UnliftedNewtypes]
   unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes
-  case new_or_data of
-    NewType | unlifted_newtypes -> newOpenTypeKind
-    _ -> pure liftedTypeKind
+  return $ case new_or_data of
+    NewType | unlifted_newtypes -> OpenKind
+    _ -> TheKind liftedTypeKind
 
 {- Note [Data declaration default result kind]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2445,7 +2433,7 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
        -- have checked that the number of patterns matches tyConArity
 
        -- This code is closely related to the code
-       -- in TcHsType.kcDeclHeader_cusk
+       -- in TcHsType.kcCheckDeclHeader_cusk
        ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty)))
                <- pushTcLevelM_                                $
                   solveEqualities                              $