-tc_hs_type_kind ty@(MonoTyVar name)
- = tcFunType ty []
-
-tc_hs_type_kind (MonoListTy _ ty)
- = tc_hs_type ty `thenTc` \ tau_ty ->
- returnTc (mkBoxedTypeKind, mkListTy tau_ty)
-
-tc_hs_type_kind (MonoTupleTy _ tys)
- = mapTc tc_hs_type tys `thenTc` \ tau_tys ->
- returnTc (mkBoxedTypeKind, mkTupleTy (length tys) tau_tys)
-
-tc_hs_type_kind (MonoFunTy ty1 ty2)
- = tc_hs_type ty1 `thenTc` \ tau_ty1 ->
- tc_hs_type ty2 `thenTc` \ tau_ty2 ->
- returnTc (mkBoxedTypeKind, mkFunTy tau_ty1 tau_ty2)
-
-tc_hs_type_kind (MonoTyApp ty1 ty2)
- = tcTyApp ty1 [ty2]
-
-tc_hs_type_kind (HsForAllTy tv_names context ty)
- = tcTyVarScope tv_names $ \ tyvars ->
- tcContext context `thenTc` \ theta ->
- tc_hs_type ty `thenTc` \ tau ->
- -- For-all's are of kind type!
- returnTc (mkBoxedTypeKind, mkSigmaTy tyvars theta tau)
-
--- for unfoldings, and instance decls, only:
-tc_hs_type_kind (MonoDictTy class_name tys)
- = tcClassAssertion (class_name, tys) `thenTc` \ (clas, arg_tys) ->
- returnTc (mkBoxedTypeKind, mkDictTy clas arg_tys)
+\begin{code}
+tc_boxed_type :: RenamedHsType -> TcM s Type
+tc_boxed_type ty
+ = tc_type_kind ty `thenTc` \ (actual_kind, tc_ty) ->
+ tcAddErrCtxt (typeKindCtxt ty)
+ (unifyKind boxedTypeKind actual_kind) `thenTc_`
+ returnTc tc_ty
+
+tc_type :: RenamedHsType -> TcM s Type
+tc_type ty
+ -- The type ty must be a *type*, but it can be boxed
+ -- or unboxed. So we check that is is of form (Type bv)
+ -- using unifyTypeKind
+ = tc_type_kind ty `thenTc` \ (actual_kind, tc_ty) ->
+ tcAddErrCtxt (typeKindCtxt ty)
+ (unifyTypeKind actual_kind) `thenTc_`
+ returnTc tc_ty
+
+tc_type_kind :: RenamedHsType -> TcM s (TcKind, Type)
+tc_type_kind ty@(MonoTyVar name)
+ = tc_app ty []
+
+tc_type_kind (MonoListTy ty)
+ = tc_boxed_type ty `thenTc` \ tau_ty ->
+ returnTc (boxedTypeKind, mkListTy tau_ty)
+
+tc_type_kind (MonoTupleTy tys True {-boxed-})
+ = mapTc tc_boxed_type tys `thenTc` \ tau_tys ->
+ returnTc (boxedTypeKind, mkTupleTy (length tys) tau_tys)
+
+tc_type_kind (MonoTupleTy tys False {-unboxed-})
+ = mapTc tc_type tys `thenTc` \ tau_tys ->
+ returnTc (unboxedTypeKind, mkUnboxedTupleTy (length tys) tau_tys)
+
+tc_type_kind (MonoFunTy ty1 ty2)
+ = tc_type ty1 `thenTc` \ tau_ty1 ->
+ tc_type ty2 `thenTc` \ tau_ty2 ->
+ returnTc (boxedTypeKind, mkFunTy tau_ty1 tau_ty2)
+
+tc_type_kind (MonoTyApp ty1 ty2)
+ = tc_app ty1 [ty2]
+
+tc_type_kind (MonoIParamTy n ty)
+ = tc_type ty `thenTc` \ tau ->
+ returnTc (boxedTypeKind, mkPredTy (IParam n tau))
+
+tc_type_kind (MonoDictTy class_name tys)
+ = tcClassAssertion (HsPClass class_name tys) `thenTc` \ (Class clas arg_tys) ->
+ returnTc (boxedTypeKind, mkDictTy clas arg_tys)
+
+tc_type_kind (MonoUsgTy usg ty)
+ = newUsg usg `thenTc` \ usg' ->
+ tc_type_kind ty `thenTc` \ (kind, tc_ty) ->
+ returnTc (kind, mkUsgTy usg' tc_ty)
+ where
+ newUsg usg = case usg of
+ MonoUsOnce -> returnTc UsOnce
+ MonoUsMany -> returnTc UsMany
+ MonoUsVar uv_name -> tcLookupUVar uv_name `thenTc` \ uv ->
+ returnTc (UsVar uv)
+
+tc_type_kind (MonoUsgForAllTy uv_name ty)
+ = let
+ uv = mkNamedUVar uv_name
+ in
+ tcExtendUVarEnv uv_name uv $
+ tc_type_kind ty `thenTc` \ (kind, tc_ty) ->
+ returnTc (kind, mkUsForAllTy uv tc_ty)
+
+tc_type_kind (HsForAllTy (Just tv_names) context ty)
+ = tcExtendTyVarScope tv_names $ \ tyvars ->
+ tcContext context `thenTc` \ theta ->
+ tc_type_kind ty `thenTc` \ (kind, tau) ->
+ tcGetInScopeTyVars `thenTc` \ in_scope_vars ->
+ let
+ body_kind | null theta = kind
+ | otherwise = boxedTypeKind
+ -- 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
+ check ct@(Class c tys) | ambiguous = failWithTc (ambigErr (c,tys) tau)
+ where ct_vars = tyVarsOfTypes tys
+ forall_tyvars = map varName in_scope_vars
+ tau_vars = tyVarsOfType tau
+ ambig ct_var = (varName ct_var `elem` forall_tyvars) &&
+ not (ct_var `elemUFM` tau_vars)
+ ambiguous = foldUFM ((||) . ambig) False ct_vars
+ check _ = returnTc ()
+ in
+ mapTc check theta `thenTc_`
+ returnTc (body_kind, mkSigmaTy tyvars theta tau)