2 % (c) The AQUA Project, Glasgow University, 1996
4 \section[TcTyDecls]{Typecheck type declarations}
7 #include "HsVersions.h"
17 import HsSyn ( TyDecl(..), ConDecl(..), ConDetails(..), BangType(..), HsExpr(..),
18 Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
19 HsBinds(..), HsLit, Stmt, DoOrListComp, ArithSeqInfo,
20 SYN_IE(RecFlag), nonRecursive, andMonoBinds,
21 HsType, Fake, InPat, HsTyVar, Fixity,
24 import HsTypes ( getTyVarName )
25 import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) )
26 import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType,
27 SYN_IE(TcHsBinds), TcIdOcc(..), SYN_IE(TcMonoBinds)
29 import Inst ( newDicts, InstOrigin(..), Inst )
30 import TcMonoType ( tcHsTypeKind, tcHsType, tcContext )
31 import TcSimplify ( tcSimplifyThetas )
32 import TcType ( tcInstTyVars, tcInstType, tcInstId )
33 import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
34 newLocalId, newLocalIds, tcLookupClassByKey
37 import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
39 import PprType ( GenClass, GenType{-instance Outputable-},
40 GenTyVar{-instance Outputable-}{-ToDo:possibly rm-}
42 import CoreUnfold ( getUnfoldingTemplate )
43 import Class ( GenClass{-instance Eq-}, classInstEnv, SYN_IE(Class) )
44 import Id ( mkDataCon, dataConSig, mkRecordSelId, idType,
45 dataConFieldLabels, dataConStrictMarks,
46 StrictnessMark(..), getIdUnfolding,
47 GenId{-instance NamedThing-},
51 import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
52 import SpecEnv ( SpecEnv, nullSpecEnv )
53 import Name ( nameSrcLoc, isLocallyDefined, getSrcLoc,
54 OccName(..), Name{-instance Ord3-},
57 import Outputable ( Outputable(..), interpp'SP )
59 import TyCon ( TyCon, NewOrData, mkSynTyCon, mkDataTyCon, isAlgTyCon,
60 isSynTyCon, tyConDataCons
62 import Type ( GenType, -- instances
63 typeKind, getTyVar, tyVarsOfTypes, eqTy, splitSigmaTy,
64 applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
65 splitFunTy, mkTyVarTy, getTyVar_maybe,
68 import TyVar ( tyVarKind, elementOfTyVarSet,
69 GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
70 import Unique ( Unique {- instance Eq -}, evalClassKey )
71 import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, SYN_IE(UniqSet) )
72 import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic, Ord3(..) )
76 tcTyDecl :: RenamedTyDecl -> TcM s TyCon
83 tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
84 = tcAddSrcLoc src_loc $
85 tcAddErrCtxt (tySynCtxt tycon_name) $
88 tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
89 mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) tyvar_names
90 `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
93 tcHsTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
95 -- Unify tycon kind with (k1->...->kn->rhs)
97 (foldr mkTcArrowKind rhs_kind tyvar_kinds)
100 -- Getting the TyCon's kind is a bit of a nuisance. We can't use the tycon_kind,
101 -- because that's a TcKind and may not yet be fully unified with other kinds.
102 -- We could have augmented the tycon environment with a knot-tied kind,
103 -- but the simplest thing to do seems to be to get the Kind by (lazily)
104 -- looking at the tyvars and rhs_ty.
105 result_kind, final_tycon_kind :: Kind -- NB not TcKind!
106 result_kind = typeKind rhs_ty
107 final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars
109 -- Construct the tycon
110 tycon = mkSynTyCon (getName tycon_name)
119 Algebraic data and newtype decls
120 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
123 tcTyDecl (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc)
124 = tcAddSrcLoc src_loc $
125 tcAddErrCtxt (tyDataCtxt tycon_name) $
128 tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
129 mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName)
130 tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
131 tc_derivs derivings `thenTc` \ derived_classes ->
133 -- Typecheck the context
134 tcContext context `thenTc` \ ctxt ->
136 -- Unify tycon kind with (k1->...->kn->Type)
138 (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
142 mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
143 `thenTc` \ con_ids ->
145 -- Construct the tycon
146 final_tycon_kind :: Kind -- NB not TcKind!
147 final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars
149 tycon = mkDataTyCon (getName tycon_name)
159 tc_derivs Nothing = returnTc []
160 tc_derivs (Just ds) = mapTc tc_deriv ds
163 = tcLookupClass name `thenTc` \ (_, clas) ->
167 Generating constructor/selector bindings for data declarations
168 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
171 mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds s)
172 mkDataBinds [] = returnTc ([], EmptyMonoBinds)
173 mkDataBinds (tycon : tycons)
174 | isSynTyCon tycon = mkDataBinds tycons
175 | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) ->
176 mkDataBinds tycons `thenTc` \ (ids2, b2) ->
177 returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
179 mkDataBinds_one tycon
180 = ASSERT( isAlgTyCon tycon )
181 mapTc checkConstructorContext data_cons `thenTc_`
182 mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
184 data_ids = data_cons ++ sel_ids
186 -- For the locally-defined things
187 -- we need to turn the unfoldings inside the Ids into bindings,
188 binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id))
189 | data_id <- data_ids, isLocallyDefined data_id
192 returnTc (data_ids, andMonoBinds binds)
194 data_cons = tyConDataCons tycon
195 fields = [ (con, field) | con <- data_cons,
196 field <- dataConFieldLabels con
199 -- groups is list of fields that share a common name
200 groups = equivClasses cmp_name fields
201 cmp_name (_, field1) (_, field2)
202 = fieldLabelName field1 `cmp` fieldLabelName field2
205 -- Check that all the types of all the strict arguments are in Eval
208 checkConstructorContext con_id
209 | not (isLocallyDefined con_id)
212 | otherwise -- It is locally defined
213 = tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
215 strict_marks = dataConStrictMarks con_id
216 (tyvars,theta,tau) = splitSigmaTy (idType con_id)
217 (arg_tys, result_ty) = splitFunTy tau
219 eval_theta = [ (eval_clas,arg_ty)
220 | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
224 tcSimplifyThetas classInstEnv theta eval_theta `thenTc` \ eval_theta' ->
225 checkTc (null eval_theta')
226 (missingEvalErr con_id eval_theta')
230 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
231 -- These fields all have the same name, but are from
232 -- different constructors in the data type
233 -- Check that all the fields in the group have the same type
234 -- This check assumes that all the constructors of a given
235 -- data type use the same type variables
236 = checkTc (all (eqTy field_ty) other_tys)
237 (fieldTypeMisMatch field_name) `thenTc_`
240 field_ty = fieldLabelType first_field_label
241 field_name = fieldLabelName first_field_label
242 other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
243 (tyvars, _, _, _, _, _) = dataConSig first_con
244 data_ty = applyTyCon tycon (mkTyVarTys tyvars)
245 -- tyvars of first_con may be free in field_ty
246 -- Now build the selector
249 selector_ty = mkForAllTys tyvars $
254 selector_id = mkRecordSelId first_field_label selector_ty
260 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
262 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc)
263 = tcDataCon tycon tyvars ctxt name btys src_loc
265 tcConDecl tycon tyvars ctxt (ConDecl op ex_ctxt (InfixCon bty1 bty2) src_loc)
266 = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
268 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc)
269 = tcAddSrcLoc src_loc $
270 tcHsType ty `thenTc` \ arg_ty ->
272 data_con = mkDataCon (getName name)
274 [{- No labelled fields -}]
283 tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc)
284 = tcAddSrcLoc src_loc $
285 mapTc tcField fields `thenTc` \ field_label_infos_s ->
287 field_label_infos = concat field_label_infos_s
288 stricts = [strict | (_, _, strict) <- field_label_infos]
289 arg_tys = [ty | (_, ty, _) <- field_label_infos]
291 field_labels = [ mkFieldLabel (getName name) ty tag
292 | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
294 data_con = mkDataCon (getName name)
298 (thinContext arg_tys ctxt)
305 tcField (field_label_names, bty)
306 = tcHsType (get_pty bty) `thenTc` \ field_ty ->
307 returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
309 tcDataCon tycon tyvars ctxt name btys src_loc
310 = tcAddSrcLoc src_loc $
312 stricts = map get_strictness btys
313 tys = map get_pty btys
315 mapTc tcHsType tys `thenTc` \ arg_tys ->
317 data_con = mkDataCon (getName name)
319 [{- No field labels -}]
321 (thinContext arg_tys ctxt)
328 -- The context for a data constructor should be limited to
329 -- the type variables mentioned in the arg_tys
330 thinContext arg_tys ctxt
331 = filter in_arg_tys ctxt
333 arg_tyvars = tyVarsOfTypes arg_tys
334 in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
336 get_strictness (Banged _) = MarkedStrict
337 get_strictness (Unbanged _) = NotMarkedStrict
339 get_pty (Banged ty) = ty
340 get_pty (Unbanged ty) = ty
348 tySynCtxt tycon_name sty
349 = hsep [ptext SLIT("In the type declaration for"), ppr sty tycon_name]
351 tyDataCtxt tycon_name sty
352 = hsep [ptext SLIT("In the data declaration for"), ppr sty tycon_name]
354 tyNewCtxt tycon_name sty
355 = hsep [ptext SLIT("In the newtype declaration for"), ppr sty tycon_name]
357 fieldTypeMisMatch field_name sty
358 = sep [ptext SLIT("Declared types differ for field"), ppr sty field_name]
360 missingEvalErr con eval_theta sty
361 = hsep [ptext SLIT("Missing Eval context for constructor"),
363 char ':', ppr sty eval_theta]