2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
7 #include "HsVersions.h"
9 module TcMonoType ( tcHsType, tcHsTypeKind, tcContext, tcTyVarScope ) where
13 import HsSyn ( HsType(..), HsTyVar(..), Fake )
14 import RnHsSyn ( RenamedHsType(..), RenamedContext(..) )
17 import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv )
18 import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind,
19 mkTcArrowKind, unifyKind, newKindVar,
20 kindToTcKind, tcDefaultKind
22 import Type ( GenType, SYN_IE(Type), SYN_IE(ThetaType),
23 mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy,
26 import TyVar ( GenTyVar, SYN_IE(TyVar), mkTyVar )
28 import PrelInfo ( cCallishClassKeys )
29 import TyCon ( TyCon )
30 import Name ( Name, OccName, isTvOcc, getOccName )
31 import TysWiredIn ( mkListTy, mkTupleTy )
32 import Unique ( Unique )
35 import UniqFM ( Uniquable(..) )
36 import Util ( zipWithEqual, zipLazy, panic{-, pprPanic ToDo:rm-} )
43 tcHsType and tcHsTypeKind
44 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
46 tcHsType checks that the type really is of kind Type!
49 tcHsType :: RenamedHsType -> TcM s Type
52 = tcHsTypeKind ty `thenTc` \ (kind,ty) ->
53 unifyKind kind mkTcTypeKind `thenTc_`
57 tcHsTypeKind does the real work. It returns a kind and a type.
60 tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type)
62 -- This equation isn't needed (the next one would handle it fine)
63 -- but it's rather a common case, so we handle it directly
64 tcHsTypeKind (MonoTyVar name)
65 | isTvOcc (getOccName name)
66 = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
67 returnTc (kind, mkTyVarTy tyvar)
69 tcHsTypeKind ty@(MonoTyVar name)
72 tcHsTypeKind (MonoListTy _ ty)
73 = tcHsType ty `thenTc` \ tau_ty ->
74 returnTc (mkTcTypeKind, mkListTy tau_ty)
76 tcHsTypeKind (MonoTupleTy _ tys)
77 = mapTc tcHsType tys `thenTc` \ tau_tys ->
78 returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
80 tcHsTypeKind (MonoFunTy ty1 ty2)
81 = tcHsType ty1 `thenTc` \ tau_ty1 ->
82 tcHsType ty2 `thenTc` \ tau_ty2 ->
83 returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
85 tcHsTypeKind (MonoTyApp ty1 ty2)
88 tcHsTypeKind (HsForAllTy tv_names context ty)
89 = tcTyVarScope tv_names $ \ tyvars ->
90 tcContext context `thenTc` \ theta ->
91 tcHsType ty `thenTc` \ tau ->
92 -- For-all's are of kind type!
93 returnTc (mkTcTypeKind, mkSigmaTy tyvars theta tau)
95 -- for unfoldings only:
96 tcHsTypeKind (MonoDictTy class_name ty)
97 = tcHsTypeKind ty `thenTc` \ (arg_kind, arg_ty) ->
98 tcLookupClass class_name `thenTc` \ (class_kind, clas) ->
99 unifyKind class_kind arg_kind `thenTc_`
100 returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
103 Help functions for type applications
104 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
106 tcTyApp (MonoTyApp ty1 ty2) tys
107 = tcTyApp ty1 (ty2:tys)
114 = mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
115 tcFunType ty arg_tys `thenTc` \ (fun_kind, result_ty) ->
117 -- Check argument compatibility; special ca
118 newKindVar `thenNF_Tc` \ result_kind ->
119 unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds)
121 returnTc (result_kind, result_ty)
123 tcFunType (MonoTyVar name) arg_tys
124 | isTvOcc (getOccName name) -- Must be a type variable
125 = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
126 returnTc (kind, foldl mkAppTy (mkTyVarTy tyvar) arg_tys)
128 | otherwise -- Must be a type constructor
129 = tcLookupTyCon name `thenTc` \ (kind,maybe_arity,tycon) ->
131 Nothing -> returnTc (kind, foldl mkAppTy (mkTyConTy tycon) arg_tys)
132 Just arity -> checkTc (arity == n_args) (err arity) `thenTc_`
133 returnTc (kind, mkSynTy tycon arg_tys)
135 err arity = arityErr "Type synonym constructor" name arity n_args
136 n_args = length arg_tys
139 = tcHsTypeKind ty `thenTc` \ (fun_kind, fun_ty) ->
140 returnTc (fun_kind, foldl mkAppTy fun_ty arg_tys)
148 tcContext :: RenamedContext -> TcM s ThetaType
149 tcContext context = mapTc tcClassAssertion context
151 tcClassAssertion (class_name, ty)
152 = checkTc (canBeUsedInContext class_name)
153 (naughtyCCallContextErr class_name) `thenTc_`
155 tcLookupClass class_name `thenTc` \ (class_kind, clas) ->
156 tcHsTypeKind ty `thenTc` \ (ty_kind, ty) ->
158 unifyKind class_kind ty_kind `thenTc_`
163 HACK warning: Someone discovered that @CCallable@ and @CReturnable@
164 could be used in contexts such as:
166 foo :: CCallable a => a -> PrimIO Int
169 Doing this utterly wrecks the whole point of introducing these
170 classes so we specifically check that this isn't being done.
173 canBeUsedInContext :: Name -> Bool
174 canBeUsedInContext n = not (uniqueOf n `elem` cCallishClassKeys)
177 Type variables, with knot tying!
178 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
181 :: [HsTyVar Name] -- Names of some type variables
182 -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
185 tcTyVarScope tyvar_names thing_inside
186 = mapAndUnzipNF_Tc tcHsTyVar tyvar_names `thenNF_Tc` \ (names, kinds) ->
188 fixTc (\ ~(rec_tyvars, _) ->
189 -- Ok to look at names, kinds, but not tyvars!
191 tcExtendTyVarEnv names (kinds `zipLazy` rec_tyvars)
192 (thing_inside rec_tyvars) `thenTc` \ result ->
194 -- Get the tyvar's Kinds from their TcKinds
195 mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' ->
197 -- Construct the real TyVars
199 tyvars = zipWithEqual "tcTyVarScope" mkTyVar names kinds'
201 returnTc (tyvars, result)
202 ) `thenTc` \ (_,result) ->
205 tcHsTyVar (UserTyVar name)
206 = newKindVar `thenNF_Tc` \ tc_kind ->
207 returnNF_Tc (name, tc_kind)
208 tcHsTyVar (IfaceTyVar name kind)
209 = returnNF_Tc (name, kindToTcKind kind)
215 naughtyCCallContextErr clas_name sty
216 = sep [ptext SLIT("Can't use class"), ppr sty clas_name, ptext SLIT("in a context")]