2 % (c) The AQUA Project, Glasgow University, 1996
4 \section[TcTyDecls]{Typecheck type declarations}
13 #include "HsVersions.h"
15 import HsSyn ( MonoBinds(..),
16 TyDecl(..), ConDecl(..), ConDetails(..), BangType(..),
19 import HsTypes ( getTyVarName )
20 import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) )
21 import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType,
22 TcHsBinds, TcMonoBinds
24 import BasicTypes ( RecFlag(..), NewOrData(..) )
26 import Inst ( newDicts, InstOrigin(..), Inst )
27 import TcMonoType ( tcHsTypeKind, tcHsType, tcContext )
28 import TcSimplify ( tcSimplifyCheckThetas )
29 import TcType ( tcInstTyVars )
30 import TcEnv ( TcIdOcc(..), tcInstId,
31 tcLookupTyCon, tcLookupTyVar, tcLookupClass,
32 newLocalId, newLocalIds, tcLookupClassByKey
35 import TcKind ( TcKind, unifyKind, mkArrowKind, mkBoxedTypeKind )
37 import Class ( classInstEnv, Class )
38 import MkId ( mkDataCon, mkRecordSelId )
39 import Id ( dataConSig, idType,
40 dataConFieldLabels, dataConStrictMarks,
41 StrictnessMark(..), getIdUnfolding,
44 import CoreUnfold ( getUnfoldingTemplate )
46 import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
47 import Name ( nameSrcLoc, isLocallyDefined, getSrcLoc,
52 import TyCon ( TyCon, mkSynTyCon, mkDataTyCon, isAlgTyCon,
53 isSynTyCon, tyConDataCons
55 import Type ( typeKind, getTyVar, tyVarsOfTypes, splitSigmaTy,
56 mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
57 splitFunTys, mkTyVarTy, getTyVar_maybe,
58 isUnboxedType, Type, ThetaType
60 import TyVar ( tyVarKind, elementOfTyVarSet, intersectTyVarSets, isEmptyTyVarSet,
62 import Unique ( evalClassKey )
63 import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet )
64 import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic )
68 tcTyDecl :: RecFlag -> RenamedTyDecl -> TcM s TyCon
75 tcTyDecl is_rec (TySynonym tycon_name tyvar_names rhs src_loc)
76 = tcAddSrcLoc src_loc $
77 tcAddErrCtxt (tySynCtxt tycon_name) $
80 tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
81 mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) tyvar_names
82 `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
85 tcHsTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
87 -- Unify tycon kind with (k1->...->kn->rhs)
89 (foldr mkArrowKind rhs_kind tyvar_kinds)
92 -- Getting the TyCon's kind is a bit of a nuisance. We can't use the tycon_kind,
93 -- because that's a TcKind and may not yet be fully unified with other kinds.
94 -- We could have augmented the tycon environment with a knot-tied kind,
95 -- but the simplest thing to do seems to be to get the Kind by (lazily)
96 -- looking at the tyvars and rhs_ty.
97 result_kind, final_tycon_kind :: Kind -- NB not TcKind!
98 result_kind = typeKind rhs_ty
99 final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars
101 -- Construct the tycon
102 tycon = mkSynTyCon (getName tycon_name)
111 Algebraic data and newtype decls
112 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
115 tcTyDecl is_rec (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc)
116 = tcAddSrcLoc src_loc $
117 let ctxt = case data_or_new of
118 NewType -> tyNewCtxt tycon_name
119 DataType -> tyDataCtxt tycon_name
124 tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
125 mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName)
126 tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
127 tc_derivs derivings `thenTc` \ derived_classes ->
129 -- Typecheck the context
130 tcContext context `thenTc` \ ctxt ->
132 -- Unify tycon kind with (k1->...->kn->Type)
134 (foldr mkArrowKind mkBoxedTypeKind tyvar_kinds)
138 mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
139 `thenTc` \ con_ids ->
141 -- Construct the tycon
142 final_tycon_kind :: Kind -- NB not TcKind!
143 final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars
145 tycon = mkDataTyCon (getName tycon_name)
151 Nothing -- Not a dictionary
157 tc_derivs Nothing = returnTc []
158 tc_derivs (Just ds) = mapTc tc_deriv ds
161 = tcLookupClass name `thenTc` \ (_, clas) ->
165 Generating constructor/selector bindings for data declarations
166 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
169 mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds s)
170 mkDataBinds [] = returnTc ([], EmptyMonoBinds)
171 mkDataBinds (tycon : tycons)
172 | isSynTyCon tycon = mkDataBinds tycons
173 | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) ->
174 mkDataBinds tycons `thenTc` \ (ids2, b2) ->
175 returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
177 mkDataBinds_one tycon
178 = ASSERT( isAlgTyCon tycon )
179 mapTc checkConstructorContext data_cons `thenTc_`
180 mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
182 data_ids = data_cons ++ sel_ids
184 -- For the locally-defined things
185 -- we need to turn the unfoldings inside the Ids into bindings,
186 binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id))
187 | data_id <- data_ids, isLocallyDefined data_id
190 returnTc (data_ids, andMonoBinds binds)
192 data_cons = tyConDataCons tycon
193 fields = [ (con, field) | con <- data_cons,
194 field <- dataConFieldLabels con
197 -- groups is list of fields that share a common name
198 groups = equivClasses cmp_name fields
199 cmp_name (_, field1) (_, field2)
200 = fieldLabelName field1 `compare` fieldLabelName field2
203 -- Check that all the types of all the strict arguments are in Eval
206 checkConstructorContext con_id
207 | not (isLocallyDefined con_id)
210 | otherwise -- It is locally defined
211 = tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
213 strict_marks = dataConStrictMarks con_id
214 (tyvars, theta, ext_tyvars, ext_theta, arg_tys, _) = dataConSig con_id
216 eval_theta = [ (eval_clas, [arg_ty])
217 | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
221 tcAddErrCtxt (evalCtxt con_id eval_theta) $
222 tcSimplifyCheckThetas theta eval_theta
226 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
227 -- These fields all have the same name, but are from
228 -- different constructors in the data type
229 -- Check that all the fields in the group have the same type
230 -- This check assumes that all the constructors of a given
231 -- data type use the same type variables
232 = checkTc (all (== field_ty) other_tys)
233 (fieldTypeMisMatch field_name) `thenTc_`
236 field_ty = fieldLabelType first_field_label
237 field_name = fieldLabelName first_field_label
238 other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
239 (tyvars, _, _, _, _, _) = dataConSig first_con
240 data_ty = mkTyConApp tycon (mkTyVarTys tyvars)
241 -- tyvars of first_con may be free in field_ty
242 -- Now build the selector
245 selector_ty = mkForAllTys tyvars $
250 selector_id = mkRecordSelId first_field_label selector_ty
256 tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s Id
258 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc)
259 = tcDataCon tycon tyvars ctxt name btys src_loc
261 tcConDecl tycon tyvars ctxt (ConDecl op ex_ctxt (InfixCon bty1 bty2) src_loc)
262 = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
264 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc)
265 = tcAddSrcLoc src_loc $
266 tcHsType ty `thenTc` \ arg_ty ->
267 -- can't allow an unboxed type here, because we're effectively
268 -- going to remove the constructor while coercing it to a boxed type.
269 checkTc (not (isUnboxedType arg_ty)) (newTypeUnboxedField ty) `thenTc_`
271 data_con = mkDataCon (getName name)
273 [{- No labelled fields -}]
276 [] [] -- Temporary; existential chaps
282 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc)
283 = tcAddSrcLoc src_loc $
284 mapTc tcField fields `thenTc` \ field_label_infos_s ->
286 field_label_infos = concat field_label_infos_s
287 stricts = [strict | (_, _, strict) <- field_label_infos]
288 arg_tys = [ty | (_, ty, _) <- field_label_infos]
290 field_labels = [ mkFieldLabel (getName name) ty tag
291 | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
293 data_con = mkDataCon (getName name)
297 (thinContext arg_tys ctxt)
298 [] [] -- Temporary; existential chaps
304 tcField (field_label_names, bty)
305 = tcHsType (get_pty bty) `thenTc` \ field_ty ->
306 returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
308 tcDataCon tycon tyvars ctxt name btys src_loc
309 = tcAddSrcLoc src_loc $
311 stricts = map get_strictness btys
312 tys = map get_pty btys
314 mapTc tcHsType tys `thenTc` \ arg_tys ->
316 data_con = mkDataCon (getName name)
318 [{- No field labels -}]
320 (thinContext arg_tys ctxt)
321 [] [] -- Temporary existential chaps
327 -- The context for a data constructor should be limited to
328 -- the type variables mentioned in the arg_tys
329 thinContext arg_tys ctxt
330 = filter in_arg_tys ctxt
332 arg_tyvars = tyVarsOfTypes arg_tys
333 in_arg_tys (clas,tys) = not $ isEmptyTyVarSet $
334 tyVarsOfTypes tys `intersectTyVarSets` arg_tyvars
336 get_strictness (Banged _) = MarkedStrict
337 get_strictness (Unbanged _) = NotMarkedStrict
339 get_pty (Banged ty) = ty
340 get_pty (Unbanged ty) = ty
349 = hsep [ptext SLIT("In the type declaration for"), quotes (ppr tycon_name)]
351 tyDataCtxt tycon_name
352 = hsep [ptext SLIT("In the data declaration for"), quotes (ppr tycon_name)]
355 = hsep [ptext SLIT("In the newtype declaration for"), quotes (ppr tycon_name)]
357 fieldTypeMisMatch field_name
358 = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)]
360 newTypeUnboxedField ty
361 = sep [ptext SLIT("Newtype constructor field has an unboxed type:"),
364 evalCtxt con eval_theta
365 = hsep [ptext SLIT("When checking the Eval context for constructor:"),
367 text "::", ppr eval_theta]