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(..),
15 RenamedContext(..), RnName(..)
20 import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon,
21 tcTyVarScope, tcTyVarScopeGivenKinds
23 import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind,
24 mkTcArrowKind, unifyKind, newKindVar,
27 import Type ( GenType, Type(..), ThetaType(..),
28 mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy,
31 import TyVar ( GenTyVar, TyVar(..), mkTyVar )
32 import PrelInfo ( mkListTy, mkTupleTy )
33 import Type ( mkDictTy )
34 import Class ( cCallishClassKeys )
35 import TyCon ( TyCon, Arity(..) )
36 import Unique ( Unique )
39 import RnHsSyn ( isRnLocal, isRnClass, isRnTyCon,
40 RnName{-instance NamedThing-}
42 import Util ( zipWithEqual, panic, pprPanic{-ToDo:rm-} )
46 tcMonoType and tcMonoTypeKind
47 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
49 tcMonoType checks that the type really is of kind Type!
52 tcMonoType :: RenamedMonoType -> TcM s Type
55 = tcMonoTypeKind ty `thenTc` \ (kind,ty) ->
56 unifyKind kind mkTcTypeKind `thenTc_`
60 tcMonoTypeKind does the real work. It returns a kind and a type.
63 tcMonoTypeKind :: RenamedMonoType -> TcM s (TcKind s, Type)
65 tcMonoTypeKind (MonoTyVar name)
66 = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
67 returnTc (kind, mkTyVarTy tyvar)
70 tcMonoTypeKind (MonoListTy ty)
71 = tcMonoType ty `thenTc` \ tau_ty ->
72 returnTc (mkTcTypeKind, mkListTy tau_ty)
74 tcMonoTypeKind (MonoTupleTy tys)
75 = mapTc tcMonoType tys `thenTc` \ tau_tys ->
76 returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
78 tcMonoTypeKind (MonoFunTy ty1 ty2)
79 = tcMonoType ty1 `thenTc` \ tau_ty1 ->
80 tcMonoType ty2 `thenTc` \ tau_ty2 ->
81 returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
83 tcMonoTypeKind (MonoTyApp name tys)
84 | isRnLocal name -- Must be a type variable
85 = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
86 tcMonoTyApp kind (mkTyVarTy tyvar) tys
88 | otherwise {-isRnTyCon name-} -- Must be a type constructor
89 = tcLookupTyCon name `thenNF_Tc` \ (kind,maybe_arity,tycon) ->
91 Just arity -> tcSynApp name kind arity tycon tys -- synonum
92 Nothing -> tcMonoTyApp kind (mkTyConTy tycon) tys -- newtype or data
95 -- = pprPanic "tcMonoTypeKind:" (ppr PprDebug name)
97 -- for unfoldings only:
98 tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
99 = tcTyVarScopeGivenKinds names tc_kinds (\ tyvars ->
100 tcMonoTypeKind ty `thenTc` \ (kind, ty') ->
101 unifyKind kind mkTcTypeKind `thenTc_`
102 returnTc (mkTcTypeKind, ty')
105 (rn_names, kinds) = unzip tyvars_w_kinds
106 names = map de_rn rn_names
107 tc_kinds = map kindToTcKind kinds
110 -- for unfoldings only:
111 tcMonoTypeKind (MonoDictTy class_name ty)
112 = tcMonoTypeKind ty `thenTc` \ (arg_kind, arg_ty) ->
113 tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) ->
114 unifyKind class_kind arg_kind `thenTc_`
115 returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
118 Help functions for type applications
119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
121 tcMonoTyApp fun_kind fun_ty tys
122 = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
123 newKindVar `thenNF_Tc` \ result_kind ->
124 unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
125 returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
127 tcSynApp name syn_kind arity tycon tys
128 = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
129 newKindVar `thenNF_Tc` \ result_kind ->
130 unifyKind syn_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
132 -- Check that it's applied to the right number of arguments
133 checkTc (arity == n_args) (err arity) `thenTc_`
134 returnTc (result_kind, mkSynTy tycon arg_tys)
136 err arity = arityErr "Type synonym constructor" name arity n_args
145 tcContext :: RenamedContext -> TcM s ThetaType
146 tcContext context = mapTc tcClassAssertion context
148 tcClassAssertion (class_name, tyvar_name)
149 = checkTc (canBeUsedInContext class_name)
150 (naughtyCCallContextErr class_name) `thenTc_`
152 tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) ->
153 tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, tyvar) ->
155 unifyKind class_kind tyvar_kind `thenTc_`
157 returnTc (clas, mkTyVarTy tyvar)
160 HACK warning: Someone discovered that @CCallable@ and @CReturnable@
161 could be used in contexts such as:
163 foo :: CCallable a => a -> PrimIO Int
166 Doing this utterly wrecks the whole point of introducing these
167 classes so we specifically check that this isn't being done.
170 canBeUsedInContext :: RnName -> Bool
172 = isRnClass n && not (uniqueOf n `elem` cCallishClassKeys)
178 tcPolyType :: RenamedPolyType -> TcM s Type
179 tcPolyType (HsForAllTy tyvar_names context ty)
180 = tcTyVarScope names (\ tyvars ->
181 tcContext context `thenTc` \ theta ->
182 tcMonoType ty `thenTc` \ tau ->
183 returnTc (mkSigmaTy tyvars theta tau)
186 names = map de_rn tyvar_names
193 naughtyCCallContextErr clas_name sty
194 = ppSep [ppStr "Can't use class", ppr sty clas_name, ppStr "in a context"]