+\begin{code}
+
+kcHsTyVar :: HsTyVarBndr name -> NF_TcM s (name, TcKind)
+kcHsTyVars :: [HsTyVarBndr name] -> NF_TcM s [(name, TcKind)]
+
+kcHsTyVar (UserTyVar name) = newKindVar `thenNF_Tc` \ kind ->
+ returnNF_Tc (name, kind)
+kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (name, kind)
+
+kcHsTyVars tvs = mapNF_Tc kcHsTyVar tvs
+
+---------------------------
+kcBoxedType :: RenamedHsType -> TcM s ()
+ -- The type ty must be a *boxed* *type*
+kcBoxedType ty
+ = kcHsType ty `thenTc` \ kind ->
+ tcAddErrCtxt (typeKindCtxt ty) $
+ unifyKind boxedTypeKind kind
+
+---------------------------
+kcTypeType :: RenamedHsType -> TcM s ()
+ -- The type ty must be a *type*, but it can be boxed or unboxed.
+kcTypeType ty
+ = kcHsType ty `thenTc` \ kind ->
+ tcAddErrCtxt (typeKindCtxt ty) $
+ unifyOpenTypeKind kind
+
+---------------------------
+kcHsSigType, kcHsBoxedSigType :: RenamedHsType -> TcM s ()
+ -- Used for type signatures
+kcHsSigType = kcTypeType
+kcHsBoxedSigType = kcBoxedType
+
+---------------------------
+kcHsType :: RenamedHsType -> TcM s TcKind
+kcHsType (HsTyVar name)
+ = tcLookupTy name `thenTc` \ thing ->
+ case thing of
+ ATyVar tv -> returnTc (tyVarKind tv)
+ ATyCon tc -> returnTc (tyConKind tc)
+ AThing k -> returnTc k
+ other -> failWithTc (wrongThingErr "type" thing name)
+
+kcHsType (HsUsgTy _ ty) = kcHsType ty
+kcHsType (HsUsgForAllTy _ ty) = kcHsType ty
+
+kcHsType (HsListTy ty)
+ = kcBoxedType ty `thenTc` \ tau_ty ->
+ returnTc boxedTypeKind
+
+kcHsType (HsTupleTy (HsTupCon _ Boxed) tys)
+ = mapTc kcBoxedType tys `thenTc_`
+ returnTc boxedTypeKind
+
+kcHsType (HsTupleTy (HsTupCon _ Unboxed) tys)
+ = mapTc kcTypeType tys `thenTc_`
+ returnTc unboxedTypeKind
+
+kcHsType (HsFunTy ty1 ty2)
+ = kcTypeType ty1 `thenTc_`
+ kcTypeType ty2 `thenTc_`
+ returnTc boxedTypeKind
+
+kcHsType (HsPredTy pred)
+ = kcHsPred pred `thenTc_`
+ returnTc boxedTypeKind
+
+kcHsType ty@(HsAppTy ty1 ty2)
+ = kcHsType ty1 `thenTc` \ tc_kind ->
+ kcHsType ty2 `thenTc` \ arg_kind ->
+
+ tcAddErrCtxt (appKindCtxt (ppr ty)) $
+ case splitFunTy_maybe tc_kind of
+ Just (arg_kind', res_kind)
+ -> unifyKind arg_kind arg_kind' `thenTc_`
+ returnTc res_kind
+
+ Nothing -> newKindVar `thenNF_Tc` \ res_kind ->
+ unifyKind tc_kind (mkArrowKind arg_kind res_kind) `thenTc_`
+ returnTc res_kind
+
+kcHsType (HsForAllTy (Just tv_names) context ty)
+ = kcHsTyVars tv_names `thenNF_Tc` \ kind_env ->
+ tcExtendKindEnv kind_env $
+ kcHsContext context `thenTc_`
+ kcHsType ty `thenTc` \ kind ->
+
+ -- Context behaves like a function type
+ -- This matters. Return-unboxed-tuple analysis can
+ -- give overloaded functions like
+ -- f :: forall a. Num a => (# a->a, a->a #)
+ -- And we want these to get through the type checker
+ returnTc (if null context then
+ kind
+ else
+ boxedTypeKind)
+
+---------------------------
+kcHsContext ctxt = mapTc_ kcHsPred ctxt
+
+kcHsPred :: RenamedHsPred -> TcM s ()
+kcHsPred pred@(HsPIParam name ty)
+ = tcAddErrCtxt (appKindCtxt (ppr pred)) $
+ kcBoxedType ty
+
+kcHsPred pred@(HsPClass cls tys)
+ = tcAddErrCtxt (appKindCtxt (ppr pred)) $
+ tcLookupTy cls `thenNF_Tc` \ thing ->
+ (case thing of
+ AClass cls -> returnTc (tyConKind (classTyCon cls))
+ AThing kind -> returnTc kind
+ other -> failWithTc (wrongThingErr "class" thing cls)) `thenTc` \ kind ->
+ mapTc kcHsType tys `thenTc` \ arg_kinds ->
+ unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind)
+\end{code}
+
+\begin{code}
+kcTyVarScope :: [HsTyVarBndr Name]
+ -> TcM s a -- The kind checker
+ -> TcM s [TyVar]
+ -- Do a kind check to find out the kinds of the type variables
+ -- Then return the type variables
+
+kcTyVarScope [] kind_check = returnTc []
+ -- A useful short cut for a common case!
+
+kcTyVarScope tv_names kind_check
+ = kcHsTyVars tv_names `thenNF_Tc` \ tv_names_w_kinds ->
+ tcExtendKindEnv tv_names_w_kinds kind_check `thenTc_`
+ zonkKindEnv tv_names_w_kinds `thenNF_Tc` \ zonked_pairs ->
+ returnTc (map mk_tyvar zonked_pairs)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Checking types}
+%* *
+%************************************************************************
+