+import Type ( GenType, SYN_IE(Type), SYN_IE(ThetaType),
+ mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy,
+ mkSigmaTy, mkDictTy
+ )
+import TyVar ( GenTyVar, SYN_IE(TyVar) )
+import Class ( cCallishClassKeys )
+import TyCon ( TyCon )
+import TysWiredIn ( mkListTy, mkTupleTy )
+import Unique ( Unique )
+import PprStyle
+import Pretty
+import Util ( zipWithEqual, panic{-, pprPanic ToDo:rm-} )
+\end{code}
+
+
+tcMonoType and tcMonoTypeKind
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+tcMonoType checks that the type really is of kind Type!
+
+\begin{code}
+tcMonoType :: RenamedMonoType -> TcM s Type
+
+tcMonoType ty
+ = tcMonoTypeKind ty `thenTc` \ (kind,ty) ->
+ unifyKind kind mkTcTypeKind `thenTc_`
+ returnTc ty
+\end{code}
+
+tcMonoTypeKind does the real work. It returns a kind and a type.
+
+\begin{code}
+tcMonoTypeKind :: RenamedMonoType -> TcM s (TcKind s, Type)
+
+tcMonoTypeKind (MonoTyVar name)
+ = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
+ returnTc (kind, mkTyVarTy tyvar)
+
+
+tcMonoTypeKind (MonoListTy ty)
+ = tcMonoType ty `thenTc` \ tau_ty ->
+ returnTc (mkTcTypeKind, mkListTy tau_ty)
+
+tcMonoTypeKind (MonoTupleTy tys)
+ = mapTc tcMonoType tys `thenTc` \ tau_tys ->
+ returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
+
+tcMonoTypeKind (MonoFunTy ty1 ty2)
+ = tcMonoType ty1 `thenTc` \ tau_ty1 ->
+ tcMonoType ty2 `thenTc` \ tau_ty2 ->
+ returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
+
+tcMonoTypeKind (MonoTyApp name tys)
+ | isRnLocal name -- Must be a type variable
+ = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
+ tcMonoTyApp kind (mkTyVarTy tyvar) tys
+
+ | otherwise {-isRnTyCon name-} -- Must be a type constructor
+ = tcLookupTyCon name `thenNF_Tc` \ (kind,maybe_arity,tycon) ->
+ case maybe_arity of
+ Just arity -> tcSynApp name kind arity tycon tys -- synonum
+ Nothing -> tcMonoTyApp kind (mkTyConTy tycon) tys -- newtype or data
+
+-- | otherwise
+-- = pprPanic "tcMonoTypeKind:" (ppr PprDebug name)
+
+-- for unfoldings only:
+tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
+ = tcTyVarScopeGivenKinds names tc_kinds (\ tyvars ->
+ tcMonoTypeKind ty `thenTc` \ (kind, ty') ->
+ unifyKind kind mkTcTypeKind `thenTc_`
+ returnTc (mkTcTypeKind, ty')
+ )
+ where
+ (rn_names, kinds) = unzip tyvars_w_kinds
+ names = map de_rn rn_names
+ tc_kinds = map kindToTcKind kinds
+ de_rn (RnName n) = n
+
+-- for unfoldings only:
+tcMonoTypeKind (MonoDictTy class_name ty)
+ = tcMonoTypeKind ty `thenTc` \ (arg_kind, arg_ty) ->
+ tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) ->
+ unifyKind class_kind arg_kind `thenTc_`
+ returnTc (mkTcTypeKind, mkDictTy clas arg_ty)