2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
7 #include "HsVersions.h"
9 module TcMonoType ( tcPolyType, tcMonoType, tcMonoTypeKind, tcContext ) where
13 import HsSyn ( PolyType(..), MonoType(..), Fake )
14 import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..),
20 import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon,
21 tcExtendTyVarEnv, tcTyVarScope
23 import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind,
24 mkTcArrowKind, unifyKind, newKindVar,
27 import ErrUtils ( arityErr )
28 import Type ( GenType, Type(..), ThetaType(..),
29 mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy,
32 import TyVar ( GenTyVar, TyVar(..), mkTyVar )
33 import PrelInfo ( mkListTy, mkTupleTy )
34 import Type ( mkDictTy )
35 import Class ( cCallishClassKeys )
36 import Unique ( Unique )
37 import Name ( Name(..), getNameShortName, isTyConName, getSynNameArity )
40 import Util ( zipWithEqual, panic )
44 tcMonoType and tcMonoTypeKind
45 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
47 tcMonoType checks that the type really is of kind Type!
50 tcMonoType :: RenamedMonoType -> TcM s Type
53 = tcMonoTypeKind ty `thenTc` \ (kind,ty) ->
54 unifyKind kind mkTcTypeKind `thenTc_`
58 tcMonoTypeKind does the real work. It returns a kind and a type.
61 tcMonoTypeKind :: RenamedMonoType -> TcM s (TcKind s, Type)
63 tcMonoTypeKind (MonoTyVar name)
64 = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
65 returnTc (kind, mkTyVarTy tyvar)
68 tcMonoTypeKind (MonoListTy ty)
69 = tcMonoType ty `thenTc` \ tau_ty ->
70 returnTc (mkTcTypeKind, mkListTy tau_ty)
72 tcMonoTypeKind (MonoTupleTy tys)
73 = mapTc tcMonoType tys `thenTc` \ tau_tys ->
74 returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
76 tcMonoTypeKind (MonoFunTy ty1 ty2)
77 = tcMonoType ty1 `thenTc` \ tau_ty1 ->
78 tcMonoType ty2 `thenTc` \ tau_ty2 ->
79 returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
81 tcMonoTypeKind (MonoTyApp name tys)
82 = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
84 tc_mono_name name `thenNF_Tc` \ (fun_kind, fun_ty) ->
86 newKindVar `thenNF_Tc` \ result_kind ->
87 unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
89 -- Check for saturated application in the special case of
90 -- type synoyms. Here the renamer has kindly attached the
92 synArityCheck name (length tys) `thenTc_`
94 returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
96 -- for unfoldings only:
97 tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
98 = tcExtendTyVarEnv tyvar_names (tc_kinds `zip` tyvars) (
99 tcMonoTypeKind ty `thenTc` \ (kind, ty') ->
100 unifyKind kind mkTcTypeKind `thenTc_`
101 returnTc (mkTcTypeKind, ty')
104 (tyvar_names, kinds) = unzip tyvars_w_kinds
105 tyvars = zipWithEqual mk_tyvar tyvar_names kinds
106 tc_kinds = map kindToTcKind kinds
107 mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
109 -- for unfoldings only:
110 tcMonoTypeKind (MonoDictTy class_name ty)
111 = tcMonoTypeKind ty `thenTc` \ (arg_kind, arg_ty) ->
112 tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) ->
113 unifyKind class_kind arg_kind `thenTc_`
114 returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
117 tc_mono_name :: Name -> NF_TcM s (TcKind s, Type)
118 tc_mono_name name@(Short _ _) -- Must be a type variable
119 = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
120 returnNF_Tc (kind, mkTyVarTy tyvar)
122 tc_mono_name name | isTyConName name -- Must be a type constructor
123 = tcLookupTyCon name `thenNF_Tc` \ (kind,tycon) ->
124 returnNF_Tc (kind, mkTyConTy tycon)
126 tc_mono_name name -- Renamer should have got it right
127 = panic ("tc_mono_name:" ++ ppShow 1000 (ppr PprDebug name))
135 tcContext :: RenamedContext -> TcM s ThetaType
136 tcContext context = mapTc tcClassAssertion context
138 tcClassAssertion (class_name, tyvar_name)
139 = checkTc (canBeUsedInContext class_name)
140 (naughtyCCallContextErr class_name) `thenTc_`
142 tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) ->
143 tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, tyvar) ->
145 unifyKind class_kind tyvar_kind `thenTc_`
147 returnTc (clas, mkTyVarTy tyvar)
150 HACK warning: Someone discovered that @_CCallable@ and @_CReturnable@
151 could be used in contexts such as:
153 foo :: _CCallable a => a -> PrimIO Int
156 Doing this utterly wrecks the whole point of introducing these
157 classes so we specifically check that this isn't being done.
160 canBeUsedInContext :: Name -> Bool
161 canBeUsedInContext (ClassName uniq _ _) = not (uniq `elem` cCallishClassKeys)
162 canBeUsedInContext other = True
169 tcPolyType :: RenamedPolyType -> TcM s Type
170 tcPolyType (HsForAllTy tyvar_names context ty)
171 = tcTyVarScope tyvar_names (\ tyvars ->
172 tcContext context `thenTc` \ theta ->
173 tcMonoType ty `thenTc` \ tau ->
174 returnTc (mkSigmaTy tyvars theta tau)
181 synArityCheck :: Name -> Int -> TcM s ()
182 synArityCheck name n_args
183 = case getSynNameArity name of
184 Just arity | arity /= n_args -> failTc (err arity)
187 err arity = arityErr "Type synonym constructor" name arity n_args
193 naughtyCCallContextErr clas_name sty
194 = ppSep [ppStr "Can't use class", ppr sty clas_name, ppStr "in a context"]