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 Id ( mkDataCon, dataConSig, mkRecordSelId, idType,
39 dataConFieldLabels, dataConStrictMarks,
40 StrictnessMark(..), getIdUnfolding,
43 import CoreUnfold ( getUnfoldingTemplate )
45 import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
46 import Name ( nameSrcLoc, isLocallyDefined, getSrcLoc,
51 import TyCon ( TyCon, mkSynTyCon, mkDataTyCon, isAlgTyCon,
52 isSynTyCon, tyConDataCons
54 import Type ( typeKind, getTyVar, tyVarsOfTypes, splitSigmaTy,
55 mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
56 splitFunTys, mkTyVarTy, getTyVar_maybe,
57 isUnboxedType, Type, ThetaType
59 import TyVar ( tyVarKind, elementOfTyVarSet, intersectTyVarSets, isEmptyTyVarSet,
61 import Unique ( evalClassKey )
62 import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet )
63 import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic )
67 tcTyDecl :: RecFlag -> RenamedTyDecl -> TcM s TyCon
74 tcTyDecl is_rec (TySynonym tycon_name tyvar_names rhs src_loc)
75 = tcAddSrcLoc src_loc $
76 tcAddErrCtxt (tySynCtxt tycon_name) $
79 tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
80 mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) tyvar_names
81 `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
84 tcHsTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
86 -- Unify tycon kind with (k1->...->kn->rhs)
88 (foldr mkArrowKind rhs_kind tyvar_kinds)
91 -- Getting the TyCon's kind is a bit of a nuisance. We can't use the tycon_kind,
92 -- because that's a TcKind and may not yet be fully unified with other kinds.
93 -- We could have augmented the tycon environment with a knot-tied kind,
94 -- but the simplest thing to do seems to be to get the Kind by (lazily)
95 -- looking at the tyvars and rhs_ty.
96 result_kind, final_tycon_kind :: Kind -- NB not TcKind!
97 result_kind = typeKind rhs_ty
98 final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars
100 -- Construct the tycon
101 tycon = mkSynTyCon (getName tycon_name)
110 Algebraic data and newtype decls
111 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
114 tcTyDecl is_rec (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc)
115 = tcAddSrcLoc src_loc $
116 let ctxt = case data_or_new of
117 NewType -> tyNewCtxt tycon_name
118 DataType -> tyDataCtxt tycon_name
123 tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
124 mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName)
125 tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
126 tc_derivs derivings `thenTc` \ derived_classes ->
128 -- Typecheck the context
129 tcContext context `thenTc` \ ctxt ->
131 -- Unify tycon kind with (k1->...->kn->Type)
133 (foldr mkArrowKind mkBoxedTypeKind tyvar_kinds)
137 mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
138 `thenTc` \ con_ids ->
140 -- Construct the tycon
141 final_tycon_kind :: Kind -- NB not TcKind!
142 final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars
144 tycon = mkDataTyCon (getName tycon_name)
150 Nothing -- Not a dictionary
156 tc_derivs Nothing = returnTc []
157 tc_derivs (Just ds) = mapTc tc_deriv ds
160 = tcLookupClass name `thenTc` \ (_, clas) ->
164 Generating constructor/selector bindings for data declarations
165 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
168 mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds s)
169 mkDataBinds [] = returnTc ([], EmptyMonoBinds)
170 mkDataBinds (tycon : tycons)
171 | isSynTyCon tycon = mkDataBinds tycons
172 | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) ->
173 mkDataBinds tycons `thenTc` \ (ids2, b2) ->
174 returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
176 mkDataBinds_one tycon
177 = ASSERT( isAlgTyCon tycon )
178 mapTc checkConstructorContext data_cons `thenTc_`
179 mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
181 data_ids = data_cons ++ sel_ids
183 -- For the locally-defined things
184 -- we need to turn the unfoldings inside the Ids into bindings,
185 binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id))
186 | data_id <- data_ids, isLocallyDefined data_id
189 returnTc (data_ids, andMonoBinds binds)
191 data_cons = tyConDataCons tycon
192 fields = [ (con, field) | con <- data_cons,
193 field <- dataConFieldLabels con
196 -- groups is list of fields that share a common name
197 groups = equivClasses cmp_name fields
198 cmp_name (_, field1) (_, field2)
199 = fieldLabelName field1 `compare` fieldLabelName field2
202 -- Check that all the types of all the strict arguments are in Eval
205 checkConstructorContext con_id
206 | not (isLocallyDefined con_id)
209 | otherwise -- It is locally defined
210 = tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
212 strict_marks = dataConStrictMarks con_id
213 (tyvars, theta, ext_tyvars, ext_theta, arg_tys, _) = dataConSig con_id
215 eval_theta = [ (eval_clas, [arg_ty])
216 | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
220 tcAddErrCtxt (evalCtxt con_id eval_theta) $
221 tcSimplifyCheckThetas theta eval_theta
225 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
226 -- These fields all have the same name, but are from
227 -- different constructors in the data type
228 -- Check that all the fields in the group have the same type
229 -- This check assumes that all the constructors of a given
230 -- data type use the same type variables
231 = checkTc (all (== field_ty) other_tys)
232 (fieldTypeMisMatch field_name) `thenTc_`
235 field_ty = fieldLabelType first_field_label
236 field_name = fieldLabelName first_field_label
237 other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
238 (tyvars, _, _, _, _, _) = dataConSig first_con
239 data_ty = mkTyConApp tycon (mkTyVarTys tyvars)
240 -- tyvars of first_con may be free in field_ty
241 -- Now build the selector
244 selector_ty = mkForAllTys tyvars $
249 selector_id = mkRecordSelId first_field_label selector_ty
255 tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s Id
257 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc)
258 = tcDataCon tycon tyvars ctxt name btys src_loc
260 tcConDecl tycon tyvars ctxt (ConDecl op ex_ctxt (InfixCon bty1 bty2) src_loc)
261 = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
263 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc)
264 = tcAddSrcLoc src_loc $
265 tcHsType ty `thenTc` \ arg_ty ->
266 -- can't allow an unboxed type here, because we're effectively
267 -- going to remove the constructor while coercing it to a boxed type.
268 checkTc (not (isUnboxedType arg_ty)) (newTypeUnboxedField ty) `thenTc_`
270 data_con = mkDataCon (getName name)
272 [{- No labelled fields -}]
275 [] [] -- Temporary; existential chaps
281 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc)
282 = tcAddSrcLoc src_loc $
283 mapTc tcField fields `thenTc` \ field_label_infos_s ->
285 field_label_infos = concat field_label_infos_s
286 stricts = [strict | (_, _, strict) <- field_label_infos]
287 arg_tys = [ty | (_, ty, _) <- field_label_infos]
289 field_labels = [ mkFieldLabel (getName name) ty tag
290 | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
292 data_con = mkDataCon (getName name)
296 (thinContext arg_tys ctxt)
297 [] [] -- Temporary; existential chaps
303 tcField (field_label_names, bty)
304 = tcHsType (get_pty bty) `thenTc` \ field_ty ->
305 returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
307 tcDataCon tycon tyvars ctxt name btys src_loc
308 = tcAddSrcLoc src_loc $
310 stricts = map get_strictness btys
311 tys = map get_pty btys
313 mapTc tcHsType tys `thenTc` \ arg_tys ->
315 data_con = mkDataCon (getName name)
317 [{- No field labels -}]
319 (thinContext arg_tys ctxt)
320 [] [] -- Temporary existential chaps
326 -- The context for a data constructor should be limited to
327 -- the type variables mentioned in the arg_tys
328 thinContext arg_tys ctxt
329 = filter in_arg_tys ctxt
331 arg_tyvars = tyVarsOfTypes arg_tys
332 in_arg_tys (clas,tys) = not $ isEmptyTyVarSet $
333 tyVarsOfTypes tys `intersectTyVarSets` arg_tyvars
335 get_strictness (Banged _) = MarkedStrict
336 get_strictness (Unbanged _) = NotMarkedStrict
338 get_pty (Banged ty) = ty
339 get_pty (Unbanged ty) = ty
348 = hsep [ptext SLIT("In the type declaration for"), quotes (ppr tycon_name)]
350 tyDataCtxt tycon_name
351 = hsep [ptext SLIT("In the data declaration for"), quotes (ppr tycon_name)]
354 = hsep [ptext SLIT("In the newtype declaration for"), quotes (ppr tycon_name)]
356 fieldTypeMisMatch field_name
357 = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)]
359 newTypeUnboxedField ty
360 = sep [ptext SLIT("Newtype constructor field has an unboxed type:"),
363 evalCtxt con eval_theta
364 = hsep [ptext SLIT("When checking the Eval context for constructor:"),
366 text "::", ppr eval_theta]