+\subsection{Kind checking}
+%* *
+%************************************************************************
+
+Kind checking
+~~~~~~~~~~~~~
+When we come across the binding site for some type variables, we
+proceed in two stages
+
+1. Figure out what kind each tyvar has
+
+2. Create suitably-kinded tyvars,
+ extend the envt,
+ and typecheck the body
+
+To do step 1, we proceed thus:
+
+1a. Bind each type variable to a kind variable
+1b. Apply the kind checker
+1c. Zonk the resulting kinds
+
+The kind checker is passed to tcHsTyVars as an argument.
+
+For example, when we find
+ (forall a m. m a -> m a)
+we bind a,m to kind varibles and kind-check (m a -> m a). This
+makes a get kind *, and m get kind *->*. Now we typecheck (m a -> m a)
+in an environment that binds a and m suitably.
+
+The kind checker passed to tcHsTyVars needs to look at enough to
+establish the kind of the tyvar:
+ * For a group of type and class decls, it's just the group, not
+ the rest of the program
+ * For a tyvar bound in a pattern type signature, its the types
+ mentioned in the other type signatures in that bunch of patterns
+ * For a tyvar bound in a RULE, it's the type signatures on other
+ universally quantified variables in the rule
+
+Note that this may occasionally give surprising results. For example:
+
+ data T a b = MkT (a b)
+
+Here we deduce a::*->*, b::*.
+But equally valid would be
+ a::(*->*)-> *, b::*->*
+
+\begin{code}
+-- tcHsTyVars is used for type variables in type signatures
+-- e.g. forall a. a->a
+-- They are immutable, because they scope only over the signature
+-- They may or may not be explicitly-kinded
+tcHsTyVars :: [HsTyVarBndr Name]
+ -> TcM a -- The kind checker
+ -> ([TyVar] -> TcM b)
+ -> TcM b
+
+tcHsTyVars [] kind_check thing_inside = thing_inside []
+ -- A useful short cut for a common case!
+
+tcHsTyVars tv_names kind_check thing_inside
+ = kcHsTyVars tv_names `thenNF_Tc` \ tv_names_w_kinds ->
+ tcExtendKindEnv tv_names_w_kinds kind_check `thenTc_`
+ zonkKindEnv tv_names_w_kinds `thenNF_Tc` \ tvs_w_kinds ->
+ let
+ tyvars = mkImmutTyVars tvs_w_kinds
+ in
+ tcExtendTyVarEnv tyvars (thing_inside tyvars)
+
+-- tcScopedTyVars is used for scoped type variables
+-- e.g. \ (x::a) (y::a) -> x+y
+-- They never have explicit kinds (because this is source-code only)
+-- They are mutable (because they can get bound to a more specific type)
+tcScopedTyVars :: [Name]
+ -> TcM a -- The kind checker
+ -> TcM b
+ -> TcM b
+tcScopedTyVars [] kind_check thing_inside = thing_inside
+
+tcScopedTyVars tv_names kind_check thing_inside
+ = mapNF_Tc newNamedKindVar tv_names `thenTc` \ kind_env ->
+ tcExtendKindEnv kind_env kind_check `thenTc_`
+ zonkKindEnv kind_env `thenNF_Tc` \ tvs_w_kinds ->
+ listTc [tcNewMutTyVar name kind | (name, kind) <- tvs_w_kinds] `thenNF_Tc` \ tyvars ->
+ tcExtendTyVarEnv tyvars thing_inside
+\end{code}
+
+
+\begin{code}
+kcHsTyVar :: HsTyVarBndr name -> NF_TcM (name, TcKind)
+kcHsTyVars :: [HsTyVarBndr name] -> NF_TcM [(name, TcKind)]
+
+kcHsTyVar (UserTyVar name) = newNamedKindVar name
+kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (name, kind)
+
+kcHsTyVars tvs = mapNF_Tc kcHsTyVar tvs
+
+newNamedKindVar name = newKindVar `thenNF_Tc` \ kind ->
+ returnNF_Tc (name, kind)
+
+---------------------------
+kcLiftedType :: RenamedHsType -> TcM ()
+ -- The type ty must be a *lifted* *type*
+kcLiftedType ty
+ = kcHsType ty `thenTc` \ kind ->
+ tcAddErrCtxt (typeKindCtxt ty) $
+ unifyKind liftedTypeKind kind
+
+---------------------------
+kcTypeType :: RenamedHsType -> TcM ()
+ -- The type ty must be a *type*, but it can be lifted or unlifted.
+kcTypeType ty
+ = kcHsType ty `thenTc` \ kind ->
+ tcAddErrCtxt (typeKindCtxt ty) $
+ unifyOpenTypeKind kind
+
+---------------------------
+kcHsSigType, kcHsLiftedSigType :: RenamedHsType -> TcM ()
+ -- Used for type signatures
+kcHsSigType = kcTypeType
+kcHsSigTypes tys = mapTc_ kcHsSigType tys
+kcHsLiftedSigType = kcLiftedType
+
+---------------------------
+kcHsType :: RenamedHsType -> TcM TcKind
+kcHsType (HsTyVar name) = kcTyVar name
+
+kcHsType (HsListTy ty)
+ = kcLiftedType ty `thenTc` \ tau_ty ->
+ returnTc liftedTypeKind
+
+kcHsType (HsTupleTy (HsTupCon _ boxity _) tys)
+ = mapTc kcTypeType tys `thenTc_`
+ returnTc (case boxity of
+ Boxed -> liftedTypeKind
+ Unboxed -> unliftedTypeKind)
+
+kcHsType (HsFunTy ty1 ty2)
+ = kcTypeType ty1 `thenTc_`
+ kcTypeType ty2 `thenTc_`
+ returnTc liftedTypeKind
+
+kcHsType (HsNumTy _) -- The unit type for generics
+ = returnTc liftedTypeKind
+
+kcHsType ty@(HsOpTy ty1 op ty2)
+ = kcTyVar op `thenTc` \ op_kind ->
+ kcHsType ty1 `thenTc` \ ty1_kind ->
+ kcHsType ty2 `thenTc` \ ty2_kind ->
+ tcAddErrCtxt (appKindCtxt (ppr ty)) $
+ kcAppKind op_kind ty1_kind `thenTc` \ op_kind' ->
+ kcAppKind op_kind' ty2_kind
+
+kcHsType (HsPredTy pred)
+ = kcHsPred pred `thenTc_`
+ returnTc liftedTypeKind
+
+kcHsType ty@(HsAppTy ty1 ty2)
+ = kcHsType ty1 `thenTc` \ tc_kind ->
+ kcHsType ty2 `thenTc` \ arg_kind ->
+ tcAddErrCtxt (appKindCtxt (ppr ty)) $
+ kcAppKind tc_kind arg_kind
+
+kcHsType (HsForAllTy (Just tv_names) context ty)
+ = kcHsTyVars tv_names `thenNF_Tc` \ kind_env ->
+ tcExtendKindEnv kind_env $
+ kcHsContext context `thenTc_`
+ kcHsType ty `thenTc_`
+ returnTc liftedTypeKind
+
+---------------------------
+kcAppKind fun_kind arg_kind
+ = case tcSplitFunTy_maybe fun_kind of
+ Just (arg_kind', res_kind)
+ -> unifyKind arg_kind arg_kind' `thenTc_`
+ returnTc res_kind
+
+ Nothing -> newKindVar `thenNF_Tc` \ res_kind ->
+ unifyKind fun_kind (mkArrowKind arg_kind res_kind) `thenTc_`
+ returnTc res_kind
+
+
+---------------------------
+kcHsContext ctxt = mapTc_ kcHsPred ctxt
+
+kcHsPred :: RenamedHsPred -> TcM ()
+kcHsPred pred@(HsIParam name ty)
+ = tcAddErrCtxt (appKindCtxt (ppr pred)) $
+ kcLiftedType ty
+
+kcHsPred pred@(HsClassP cls tys)
+ = tcAddErrCtxt (appKindCtxt (ppr pred)) $
+ kcClass cls `thenTc` \ kind ->
+ mapTc kcHsType tys `thenTc` \ arg_kinds ->
+ unifyKind kind (mkArrowKinds arg_kinds liftedTypeKind)
+
+ ---------------------------
+kcTyVar name -- Could be a tyvar or a tycon
+ = tcLookup name `thenTc` \ thing ->
+ case thing of
+ AThing kind -> returnTc kind
+ ATyVar tv -> returnTc (tyVarKind tv)
+ AGlobal (ATyCon tc) -> returnTc (tyConKind tc)
+ other -> failWithTc (wrongThingErr "type" thing name)
+
+kcClass cls -- Must be a class
+ = tcLookup cls `thenNF_Tc` \ thing ->
+ case thing of
+ AThing kind -> returnTc kind
+ AGlobal (AClass cls) -> returnTc (tyConKind (classTyCon cls))
+ other -> failWithTc (wrongThingErr "class" thing cls)
+\end{code}
+
+%************************************************************************
+%* *