+tcTyClDecl1 unf_env decl
+ = tcAddDeclCtxt decl $
+ if isClassDecl decl then
+ tcClassDecl1 unf_env decl
+ else
+ tcTyDecl1 decl
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Step 1: Initial environment}
+%* *
+%************************************************************************
+
+\begin{code}
+getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
+getInitialKind (TySynonym name tyvars _ _)
+ = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
+ newKindVar `thenNF_Tc` \ result_kind ->
+ returnNF_Tc (name, mk_kind arg_kinds result_kind)
+
+getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _ _)
+ = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
+ returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
+
+getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ _ )
+ = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
+ returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
+
+mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Step 2: Kind checking}
+%* *
+%************************************************************************
+
+We need to kind check all types in the mutually recursive group
+before we know the kind of the type variables. For example:
+
+class C a where
+ op :: D b => a -> b -> b
+
+class D c where
+ bop :: (Monad c) => ...
+
+Here, the kind of the locally-polymorphic type variable "b"
+depends on *all the uses of class D*. For example, the use of
+Monad c in bop's type signature means that D must have kind Type->Type.
+
+\begin{code}
+kcTyClDecl :: RenamedTyClDecl -> TcM ()
+
+kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
+ = tcAddDeclCtxt decl $
+ kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
+ kcHsType rhs `thenTc` \ rhs_kind ->
+ unifyKind result_kind rhs_kind
+
+kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc _ _)
+ = tcAddDeclCtxt decl $
+ kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
+ kcHsContext context `thenTc_`
+ mapTc_ kc_con_decl con_decls
+ where
+ kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
+ = tcAddSrcLoc loc $
+ kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
+ tcExtendKindEnv kind_env $
+ kcConDetails ex_ctxt details
+
+kcTyClDecl decl@(ClassDecl context class_name
+ hs_tyvars fundeps class_sigs
+ _ _ _ loc)
+ = tcAddDeclCtxt decl $
+ kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
+ kcHsContext context `thenTc_`
+ mapTc_ kc_sig (filter isClassOpSig class_sigs)
+ where
+ kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
+
+kcTyClDeclBody :: Name -> [HsTyVarBndr Name] -- Kind of the tycon/cls and its tyvars
+ -> (Kind -> TcM a) -- Thing inside
+ -> TcM a
+-- Extend the env with bindings for the tyvars, taken from
+-- the kind of the tycon/class. Give it to the thing inside, and
+-- check the result kind matches
+kcTyClDeclBody tc_name hs_tyvars thing_inside
+ = tcLookupGlobal tc_name `thenNF_Tc` \ thing ->
+ let
+ kind = case thing of
+ ATyCon tc -> tyConKind tc
+ AClass cl -> tyConKind (classTyCon cl)
+ -- For some odd reason, a class doesn't include its kind
+
+ (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind
+ in
+ tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)