2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
7 module TcMonoType ( tcHsType, tcHsTypeKind, tcContext, tcTyVarScope ) where
9 #include "HsVersions.h"
11 import HsSyn ( HsType(..), HsTyVar(..), pprContext )
12 import RnHsSyn ( RenamedHsType(..), RenamedContext(..) )
15 import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv )
16 import TcKind ( TcKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind,
17 unifyKind, unifyKinds, newKindVar,
18 kindToTcKind, tcDefaultKind
20 import Type ( Type, ThetaType,
21 mkTyVarTy, mkFunTy, mkAppTy, mkSynTy,
22 mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys
24 import TyVar ( TyVar, mkTyVar )
25 import PrelInfo ( cCallishClassKeys )
26 import TyCon ( TyCon )
27 import Name ( Name, OccName, isTvOcc, getOccName )
28 import TysWiredIn ( mkListTy, mkTupleTy )
29 import Unique ( Unique, Uniquable(..) )
30 import Util ( zipWithEqual, zipLazy )
35 tcHsType and tcHsTypeKind
36 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
38 tcHsType checks that the type really is of kind Type!
41 tcHsType :: RenamedHsType -> TcM s Type
44 = tcAddErrCtxt (typeCtxt ty) $
48 = tc_hs_type_kind ty `thenTc` \ (kind,ty) ->
49 -- Check that it really is a type
50 unifyKind mkTypeKind kind `thenTc_`
54 tcHsTypeKind does the real work. It returns a kind and a type.
57 tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type)
60 = tcAddErrCtxt (typeCtxt ty) $
64 -- This equation isn't needed (the next one would handle it fine)
65 -- but it's rather a common case, so we handle it directly
66 tc_hs_type_kind (MonoTyVar name)
67 | isTvOcc (getOccName name)
68 = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
69 returnTc (kind, mkTyVarTy tyvar)
71 tc_hs_type_kind ty@(MonoTyVar name)
74 tc_hs_type_kind (MonoListTy _ ty)
75 = tc_hs_type ty `thenTc` \ tau_ty ->
76 returnTc (mkBoxedTypeKind, mkListTy tau_ty)
78 tc_hs_type_kind (MonoTupleTy _ tys)
79 = mapTc tc_hs_type tys `thenTc` \ tau_tys ->
80 returnTc (mkBoxedTypeKind, mkTupleTy (length tys) tau_tys)
82 tc_hs_type_kind (MonoFunTy ty1 ty2)
83 = tc_hs_type ty1 `thenTc` \ tau_ty1 ->
84 tc_hs_type ty2 `thenTc` \ tau_ty2 ->
85 returnTc (mkBoxedTypeKind, mkFunTy tau_ty1 tau_ty2)
87 tc_hs_type_kind (MonoTyApp ty1 ty2)
90 tc_hs_type_kind (HsForAllTy tv_names context ty)
91 = tcTyVarScope tv_names $ \ tyvars ->
92 tcContext context `thenTc` \ theta ->
93 tc_hs_type ty `thenTc` \ tau ->
94 -- For-all's are of kind type!
95 returnTc (mkBoxedTypeKind, mkSigmaTy tyvars theta tau)
97 -- for unfoldings, and instance decls, only:
98 tc_hs_type_kind (MonoDictTy class_name tys)
99 = mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
100 tcLookupClass class_name `thenTc` \ (class_kinds, clas) ->
102 arity = length class_kinds
103 n_args = length arg_kinds
104 err = arityErr "Class" class_name arity n_args
106 checkTc (arity == n_args) err `thenTc_`
107 unifyKinds class_kinds arg_kinds `thenTc_`
108 returnTc (mkBoxedTypeKind, mkDictTy clas arg_tys)
111 Help functions for type applications
112 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
114 tcTyApp (MonoTyApp ty1 ty2) tys
115 = tcTyApp ty1 (ty2:tys)
122 = mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
123 tcFunType ty arg_tys `thenTc` \ (fun_kind, result_ty) ->
125 -- Check argument compatibility
126 newKindVar `thenNF_Tc` \ result_kind ->
127 unifyKind fun_kind (foldr mkArrowKind result_kind arg_kinds)
129 returnTc (result_kind, result_ty)
131 -- (tcFunType ty arg_tys) returns (kind-of ty, mkAppTys ty arg_tys)
132 -- But not quite; for synonyms it checks the correct arity, and builds a SynTy
133 -- hence the rather strange functionality.
135 tcFunType (MonoTyVar name) arg_tys
136 | isTvOcc (getOccName name) -- Must be a type variable
137 = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
138 returnTc (kind, mkAppTys (mkTyVarTy tyvar) arg_tys)
140 | otherwise -- Must be a type constructor
141 = tcLookupTyCon name `thenTc` \ (tycon_kind,maybe_arity, tycon) ->
143 Nothing -> -- Data type or newtype
144 returnTc (tycon_kind, mkTyConApp tycon arg_tys)
146 Just arity -> -- Type synonym
147 checkTc (arity <= n_args) err_msg `thenTc_`
148 returnTc (tycon_kind, result_ty)
150 -- It's OK to have an *over-applied* type synonym
151 -- data Tree a b = ...
152 -- type Foo a = Tree [a]
153 -- f :: Foo a b -> ...
154 result_ty = mkAppTys (mkSynTy tycon (take arity arg_tys))
156 err_msg = arityErr "Type synonym constructor" name arity n_args
157 n_args = length arg_tys
160 = tc_hs_type_kind ty `thenTc` \ (fun_kind, fun_ty) ->
161 returnTc (fun_kind, mkAppTys fun_ty arg_tys)
169 tcContext :: RenamedContext -> TcM s ThetaType
170 tcContext context = tcAddErrCtxt (thetaCtxt context) $
171 mapTc tcClassAssertion context
173 tcClassAssertion (class_name, tys)
174 = checkTc (canBeUsedInContext class_name)
175 (naughtyCCallContextErr class_name) `thenTc_`
177 tcLookupClass class_name `thenTc` \ (class_kinds, clas) ->
178 mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (ty_kinds, tc_tys) ->
180 unifyKinds class_kinds ty_kinds `thenTc_`
182 returnTc (clas, tc_tys)
185 HACK warning: Someone discovered that @CCallable@ and @CReturnable@
186 could be used in contexts such as:
188 foo :: CCallable a => a -> PrimIO Int
191 Doing this utterly wrecks the whole point of introducing these
192 classes so we specifically check that this isn't being done.
195 canBeUsedInContext :: Name -> Bool
196 canBeUsedInContext n = not (uniqueOf n `elem` cCallishClassKeys)
199 Type variables, with knot tying!
200 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
203 :: [HsTyVar Name] -- Names of some type variables
204 -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
207 tcTyVarScope tyvar_names thing_inside
208 = mapAndUnzipNF_Tc tcHsTyVar tyvar_names `thenNF_Tc` \ (names, kinds) ->
210 fixTc (\ ~(rec_tyvars, _) ->
211 -- Ok to look at names, kinds, but not tyvars!
213 tcExtendTyVarEnv names (kinds `zipLazy` rec_tyvars)
214 (thing_inside rec_tyvars) `thenTc` \ result ->
216 -- Get the tyvar's Kinds from their TcKinds
217 mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' ->
219 -- Construct the real TyVars
221 tyvars = zipWithEqual "tcTyVarScope" mkTyVar names kinds'
223 returnTc (tyvars, result)
224 ) `thenTc` \ (_,result) ->
227 tcHsTyVar (UserTyVar name)
228 = newKindVar `thenNF_Tc` \ tc_kind ->
229 returnNF_Tc (name, tc_kind)
230 tcHsTyVar (IfaceTyVar name kind)
231 = returnNF_Tc (name, kindToTcKind kind)
237 naughtyCCallContextErr clas_name
238 = sep [ptext SLIT("Can't use class"), quotes (ppr clas_name), ptext SLIT("in a context")]
240 typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty)
242 thetaCtxt theta = ptext SLIT("In the context") <+> quotes (pprContext theta)