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 tcHsTypeKind (MonoTyVar name)
58 = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
59 returnTc (kind, mkTyVarTy tyvar)
62 tcHsTypeKind (MonoListTy _ ty)
63 = tcHsType ty `thenTc` \ tau_ty ->
64 returnTc (mkTcTypeKind, mkListTy tau_ty)
66 tcHsTypeKind (MonoTupleTy _ tys)
67 = mapTc tcHsType tys `thenTc` \ tau_tys ->
68 returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
70 tcHsTypeKind (MonoFunTy ty1 ty2)
71 = tcHsType ty1 `thenTc` \ tau_ty1 ->
72 tcHsType ty2 `thenTc` \ tau_ty2 ->
73 returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
75 tcHsTypeKind (MonoTyApp name tys)
76 | isTvOcc (getOccName name) -- Must be a type variable
77 = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
78 tcMonoTyApp kind (mkTyVarTy tyvar) tys
80 | otherwise -- Must be a type constructor
81 = tcLookupTyCon name `thenTc` \ (kind,maybe_arity,tycon) ->
83 Just arity -> tcSynApp name kind arity tycon tys -- synonum
84 Nothing -> tcMonoTyApp kind (mkTyConTy tycon) tys -- newtype or data
86 tcHsTypeKind (HsForAllTy tv_names context ty)
87 = tcTyVarScope tv_names $ \ tyvars ->
88 tcContext context `thenTc` \ theta ->
89 tcHsType ty `thenTc` \ tau ->
90 -- For-all's are of kind type!
91 returnTc (mkTcTypeKind, mkSigmaTy tyvars theta tau)
93 -- for unfoldings only:
94 tcHsTypeKind (MonoDictTy class_name ty)
95 = tcHsTypeKind ty `thenTc` \ (arg_kind, arg_ty) ->
96 tcLookupClass class_name `thenTc` \ (class_kind, clas) ->
97 unifyKind class_kind arg_kind `thenTc_`
98 returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
101 Help functions for type applications
102 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
104 tcMonoTyApp fun_kind fun_ty tys
105 = mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
106 newKindVar `thenNF_Tc` \ result_kind ->
107 unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
108 returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
110 tcSynApp name syn_kind arity tycon tys
111 = mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
112 newKindVar `thenNF_Tc` \ result_kind ->
113 unifyKind syn_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
115 -- Check that it's applied to the right number of arguments
116 checkTc (arity == n_args) (err arity) `thenTc_`
117 returnTc (result_kind, mkSynTy tycon arg_tys)
119 err arity = arityErr "Type synonym constructor" name arity n_args
128 tcContext :: RenamedContext -> TcM s ThetaType
129 tcContext context = mapTc tcClassAssertion context
131 tcClassAssertion (class_name, ty)
132 = checkTc (canBeUsedInContext class_name)
133 (naughtyCCallContextErr class_name) `thenTc_`
135 tcLookupClass class_name `thenTc` \ (class_kind, clas) ->
136 tcHsTypeKind ty `thenTc` \ (ty_kind, ty) ->
138 unifyKind class_kind ty_kind `thenTc_`
143 HACK warning: Someone discovered that @CCallable@ and @CReturnable@
144 could be used in contexts such as:
146 foo :: CCallable a => a -> PrimIO Int
149 Doing this utterly wrecks the whole point of introducing these
150 classes so we specifically check that this isn't being done.
153 canBeUsedInContext :: Name -> Bool
154 canBeUsedInContext n = not (uniqueOf n `elem` cCallishClassKeys)
157 Type variables, with knot tying!
158 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
161 :: [HsTyVar Name] -- Names of some type variables
162 -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
165 tcTyVarScope tyvar_names thing_inside
166 = mapAndUnzipNF_Tc tcHsTyVar tyvar_names `thenNF_Tc` \ (names, kinds) ->
168 fixTc (\ ~(rec_tyvars, _) ->
169 -- Ok to look at names, kinds, but not tyvars!
171 tcExtendTyVarEnv names (kinds `zipLazy` rec_tyvars)
172 (thing_inside rec_tyvars) `thenTc` \ result ->
174 -- Get the tyvar's Kinds from their TcKinds
175 mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' ->
177 -- Construct the real TyVars
179 tyvars = zipWithEqual "tcTyVarScope" mkTyVar names kinds'
181 returnTc (tyvars, result)
182 ) `thenTc` \ (_,result) ->
185 tcHsTyVar (UserTyVar name)
186 = newKindVar `thenNF_Tc` \ tc_kind ->
187 returnNF_Tc (name, tc_kind)
188 tcHsTyVar (IfaceTyVar name kind)
189 = returnNF_Tc (name, kindToTcKind kind)
195 naughtyCCallContextErr clas_name sty
196 = ppSep [ppStr "Can't use class", ppr sty clas_name, ppStr "in a context"]