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 )
27 import PrelInfo ( cCallishClassKeys )
28 import TyCon ( TyCon )
29 import Name ( Name, OccName, isTvOcc )
30 import TysWiredIn ( mkListTy, mkTupleTy )
31 import Unique ( Unique )
34 import Util ( zipWithEqual, zipLazy, panic{-, pprPanic ToDo:rm-} )
38 tcHsType and tcHsTypeKind
39 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
41 tcHsType checks that the type really is of kind Type!
44 tcHsType :: RenamedHsType -> TcM s Type
47 = tcHsTypeKind ty `thenTc` \ (kind,ty) ->
48 unifyKind kind mkTcTypeKind `thenTc_`
52 tcHsTypeKind does the real work. It returns a kind and a type.
55 tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type)
57 -- This equation isn't needed (the next one would handle it fine)
58 -- but it's rather a common case, so we handle it directly
59 tcHsTypeKind (MonoTyVar name)
60 | isTvOcc (getOccName name)
61 = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
62 returnTc (kind, mkTyVarTy tyvar)
64 tcHsTypeKind ty@(MonoTyVar name)
67 tcHsTypeKind (MonoListTy _ ty)
68 = tcHsType ty `thenTc` \ tau_ty ->
69 returnTc (mkTcTypeKind, mkListTy tau_ty)
71 tcHsTypeKind (MonoTupleTy _ tys)
72 = mapTc tcHsType tys `thenTc` \ tau_tys ->
73 returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
75 tcHsTypeKind (MonoFunTy ty1 ty2)
76 = tcHsType ty1 `thenTc` \ tau_ty1 ->
77 tcHsType ty2 `thenTc` \ tau_ty2 ->
78 returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
80 tcHsTypeKind (MonoTyApp ty1 ty2)
83 tcHsTypeKind (HsForAllTy tv_names context ty)
84 = tcTyVarScope tv_names $ \ tyvars ->
85 tcContext context `thenTc` \ theta ->
86 tcHsType ty `thenTc` \ tau ->
87 -- For-all's are of kind type!
88 returnTc (mkTcTypeKind, mkSigmaTy tyvars theta tau)
90 -- for unfoldings only:
91 tcHsTypeKind (MonoDictTy class_name ty)
92 = tcHsTypeKind ty `thenTc` \ (arg_kind, arg_ty) ->
93 tcLookupClass class_name `thenTc` \ (class_kind, clas) ->
94 unifyKind class_kind arg_kind `thenTc_`
95 returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
98 Help functions for type applications
99 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
101 tcTyApp (MonoTyApp ty1 ty2) tys
102 = tcTyApp ty1 (ty2:tys)
109 = mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
110 tcFunType ty arg_tys `thenTc` \ (fun_kind, result_ty) ->
112 -- Check argument compatibility; special ca
113 newKindVar `thenNF_Tc` \ result_kind ->
114 unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds)
116 returnTc (result_kind, result_ty)
118 tcFunType (MonoTyVar name) arg_tys
119 | isTvOcc (getOccName name) -- Must be a type variable
120 = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
121 returnTc (kind, foldl mkAppTy (mkTyVarTy tyvar) arg_tys)
123 | otherwise -- Must be a type constructor
124 = tcLookupTyCon name `thenTc` \ (kind,maybe_arity,tycon) ->
126 Nothing -> returnTc (kind, foldl mkAppTy (mkTyConTy tycon) arg_tys)
127 Just arity -> checkTc (arity == n_args) (err arity) `thenTc_`
128 returnTc (kind, mkSynTy tycon arg_tys)
130 err arity = arityErr "Type synonym constructor" name arity n_args
131 n_args = length arg_tys
134 = tcHsTypeKind ty `thenTc` \ (fun_kind, fun_ty) ->
135 returnTc (fun_kind, foldl mkAppTy fun_ty arg_tys)
143 tcContext :: RenamedContext -> TcM s ThetaType
144 tcContext context = mapTc tcClassAssertion context
146 tcClassAssertion (class_name, ty)
147 = checkTc (canBeUsedInContext class_name)
148 (naughtyCCallContextErr class_name) `thenTc_`
150 tcLookupClass class_name `thenTc` \ (class_kind, clas) ->
151 tcHsTypeKind ty `thenTc` \ (ty_kind, ty) ->
153 unifyKind class_kind ty_kind `thenTc_`
158 HACK warning: Someone discovered that @CCallable@ and @CReturnable@
159 could be used in contexts such as:
161 foo :: CCallable a => a -> PrimIO Int
164 Doing this utterly wrecks the whole point of introducing these
165 classes so we specifically check that this isn't being done.
168 canBeUsedInContext :: Name -> Bool
169 canBeUsedInContext n = not (uniqueOf n `elem` cCallishClassKeys)
172 Type variables, with knot tying!
173 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
176 :: [HsTyVar Name] -- Names of some type variables
177 -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
180 tcTyVarScope tyvar_names thing_inside
181 = mapAndUnzipNF_Tc tcHsTyVar tyvar_names `thenNF_Tc` \ (names, kinds) ->
183 fixTc (\ ~(rec_tyvars, _) ->
184 -- Ok to look at names, kinds, but not tyvars!
186 tcExtendTyVarEnv names (kinds `zipLazy` rec_tyvars)
187 (thing_inside rec_tyvars) `thenTc` \ result ->
189 -- Get the tyvar's Kinds from their TcKinds
190 mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' ->
192 -- Construct the real TyVars
194 tyvars = zipWithEqual "tcTyVarScope" mkTyVar names kinds'
196 returnTc (tyvars, result)
197 ) `thenTc` \ (_,result) ->
200 tcHsTyVar (UserTyVar name)
201 = newKindVar `thenNF_Tc` \ tc_kind ->
202 returnNF_Tc (name, tc_kind)
203 tcHsTyVar (IfaceTyVar name kind)
204 = returnNF_Tc (name, kindToTcKind kind)
210 naughtyCCallContextErr clas_name sty
211 = ppSep [ppPStr SLIT("Can't use class"), ppr sty clas_name, ppPStr SLIT("in a context")]