- returnTc (mkTcTypeKind, mkSigmaTy tyvars theta tau)
-
--- for unfoldings only:
-tcHsTypeKind (MonoDictTy class_name ty)
- = tcHsTypeKind ty `thenTc` \ (arg_kind, arg_ty) ->
- tcLookupClass class_name `thenTc` \ (class_kind, clas) ->
- unifyKind class_kind arg_kind `thenTc_`
- returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
+ returnTc (mkBoxedTypeKind, mkSigmaTy tyvars theta tau)
+
+-- for unfoldings, and instance decls, only:
+tc_hs_type_kind (MonoDictTy class_name tys)
+ = mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
+ tcLookupClass class_name `thenTc` \ (class_kinds, clas) ->
+ let
+ arity = length class_kinds
+ n_args = length arg_kinds
+ err = arityErr "Class" class_name arity n_args
+ in
+ checkTc (arity == n_args) err `thenTc_`
+ unifyKinds class_kinds arg_kinds `thenTc_`
+ returnTc (mkBoxedTypeKind, mkDictTy clas arg_tys)