2 % (c) The AQUA Project, Glasgow University, 1996
4 \section[TcTyDecls]{Typecheck type declarations}
7 #include "HsVersions.h"
17 import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
18 Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
19 HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo, PolyType,
20 Bind(..), MonoBinds(..), Sig,
22 import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) )
23 import TcHsSyn ( TcHsBinds(..), TcIdOcc(..), mkHsTyLam )
25 import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext )
26 import TcType ( tcInstTyVars, tcInstType )
27 import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
31 import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
33 import Id ( mkDataCon, dataConSig, mkRecordSelectorId,
34 dataConFieldLabels, StrictnessMark(..)
37 import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
38 import SpecEnv ( SpecEnv(..), nullSpecEnv )
39 import Name ( getNameFullName, Name(..) )
41 import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, tyConDataCons )
42 import Type ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy, applyTyCon,
43 mkForAllTys, mkFunTy )
44 import TyVar ( getTyVarKind, elementOfTyVarSet )
45 import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) )
46 import Util ( panic, equivClasses )
50 tcTyDecl :: RenamedTyDecl -> TcM s TyCon
57 tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
58 = tcAddSrcLoc src_loc $
59 tcAddErrCtxt (tySynCtxt tycon_name) $
62 tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
63 mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
66 tcMonoTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
68 -- Unify tycon kind with (k1->...->kn->rhs)
70 (foldr mkTcArrowKind rhs_kind tyvar_kinds)
73 -- Getting the TyCon's kind is a bit of a nuisance. We can't use the tycon_kind,
74 -- because that's a TcKind and may not yet be fully unified with other kinds.
75 -- We could have augmented the tycon environment with a knot-tied kind,
76 -- but the simplest thing to do seems to be to get the Kind by (lazily)
77 -- looking at the tyvars and rhs_ty.
78 result_kind, final_tycon_kind :: Kind -- NB not TcKind!
79 result_kind = getTypeKind rhs_ty
80 final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars
82 -- Construct the tycon
83 tycon = mkSynTyCon (getItsUnique tycon_name)
84 (getNameFullName tycon_name)
93 Algebraic data and newtype decls
94 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
97 tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc)
98 = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
100 tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
101 = tcTyDataOrNew NewType context tycon_name tyvar_names con_decl derivings pragmas src_loc
104 tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
105 = tcAddSrcLoc src_loc $
106 tcAddErrCtxt (tyDataCtxt tycon_name) $
109 tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
110 mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
111 tc_derivs derivings `thenNF_Tc` \ derived_classes ->
113 -- Typecheck the context
114 tcContext context `thenTc` \ ctxt ->
116 -- Unify tycon kind with (k1->...->kn->Type)
118 (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
122 mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
123 `thenTc` \ con_ids ->
125 -- Construct the tycon
126 final_tycon_kind :: Kind -- NB not TcKind!
127 final_tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind rec_tyvars
129 tycon = mkDataTyCon (getItsUnique tycon_name)
131 (getNameFullName tycon_name)
140 tc_derivs Nothing = returnNF_Tc []
141 tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
144 = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
148 Generating selector bindings for record delarations
149 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
152 tcRecordSelectors :: TyCon -> TcM s ([Id], TcHsBinds s)
153 tcRecordSelectors tycon
154 = mapAndUnzipTc (tcRecordSelector tycon) groups `thenTc` \ (ids, binds) ->
155 returnTc (ids, SingleBind (NonRecBind (foldr AndMonoBinds EmptyMonoBinds binds)))
157 data_cons = tyConDataCons tycon
158 fields = [ (con, field) | con <- data_cons,
159 field <- dataConFieldLabels con
162 -- groups is list of fields that share a common name
163 groups = equivClasses cmp_name fields
164 cmp_name (_, field1) (_, field2)
165 = fieldLabelName field1 `cmp` fieldLabelName field2
168 We're going to build a record selector that looks like this:
170 data T a b c = T1 { op :: a, ...}
174 sel :: forall a b c. T a b c -> a
175 sel = /\ a b c -> \ T1 { sel = x } -> x
178 Note that the selector Id itself is used as the field
179 label; it has to be an Id, you see!
182 tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
183 = panic "tcRecordSelector: don't typecheck"
186 field_ty = fieldLabelType first_field_label
187 field_name = fieldLabelName first_field_label
188 other_tys = [fieldLabelType fl | (_, fl) <- fields]
189 (tyvars, _, _, _) = dataConSig first_con
190 -- tyvars of first_con may be free in first_ty
193 -- Check that all the fields in the group have the same type
194 -- This check assumes that all the constructors of a given
195 -- data type use the same type variables
196 checkTc (all (eqTy field_ty) other_tys)
197 (fieldTypeMisMatch field_name) `thenTc_`
199 -- Create an Id for the field itself
200 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
201 tcInstType tenv field_ty `thenNF_Tc` \ field_ty' ->
203 data_ty' = applyTyCon tycon tyvar_tys
205 newLocalId SLIT("x") field_ty' `thenNF_Tc` \ field_id ->
206 newLocalId SLIT("r") data_ty' `thenNF_Tc` \ record_id ->
208 -- Now build the selector
210 tycon_src_loc = getSrcLoc tycon
212 selector_ty = mkForAllTys tyvars' $
216 selector_id = mkRecordSelectorId first_field_label selector_ty
218 -- HsSyn is dreadfully verbose for defining the selector!
219 selector_rhs = mkHsTyLam tyvars' $
221 PatMatch (VarPat record_id) $
223 GRHSsAndBindsOut [OtherwiseGRHS selector_body tycon_src_loc]
226 selector_body = HsCase (HsVar record_id) (map mk_match fields) tycon_src_loc
228 mk_match (con_id, field_label)
229 = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
231 GRHSsAndBindsOut [OtherwiseGRHS (HsVar field_id)
232 (getSrcLoc (fieldLabelName field_label))]
236 returnTc (selector_id, VarMonoBind selector_id selector_rhs)
243 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
245 tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
246 = tcDataCon tycon tyvars ctxt name btys src_loc
248 tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
249 = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
251 tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
252 = tcAddSrcLoc src_loc $
253 tcMonoType ty `thenTc` \ arg_ty ->
255 data_con = mkDataCon (getItsUnique name)
256 (getNameFullName name)
258 [{- No labelled fields -}]
267 tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
268 = tcAddSrcLoc src_loc $
269 mapTc tcField fields `thenTc` \ field_label_infos_s ->
271 field_label_infos = concat field_label_infos_s
272 stricts = [strict | (_, _, strict) <- field_label_infos]
273 arg_tys = [ty | (_, ty, _) <- field_label_infos]
275 field_labels = [ mkFieldLabel name ty tag
276 | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags
279 data_con = mkDataCon (getItsUnique name)
280 (getNameFullName name)
284 (thinContext arg_tys ctxt)
291 tcField (field_label_names, bty)
292 = tcMonoType (get_ty bty) `thenTc` \ field_ty ->
293 returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
295 tcDataCon tycon tyvars ctxt name btys src_loc
296 = tcAddSrcLoc src_loc $
298 stricts = map get_strictness btys
299 tys = map get_ty btys
301 mapTc tcMonoType tys `thenTc` \ arg_tys ->
303 data_con = mkDataCon (getItsUnique name)
304 (getNameFullName name)
306 [{- No field labels -}]
308 (thinContext arg_tys ctxt)
315 -- The context for a data constructor should be limited to
316 -- the type variables mentioned in the arg_tys
317 thinContext arg_tys ctxt
318 = filter in_arg_tys ctxt
320 arg_tyvars = tyVarsOfTypes arg_tys
321 in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
323 get_strictness (Banged ty) = MarkedStrict
324 get_strictness (Unbanged ty) = NotMarkedStrict
326 get_ty (Banged ty) = ty
327 get_ty (Unbanged ty) = ty
335 tySynCtxt tycon_name sty
336 = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
338 tyDataCtxt tycon_name sty
339 = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
341 tyNewCtxt tycon_name sty
342 = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
344 fieldTypeMisMatch field_name sty
345 = ppSep [ppStr "Declared types differ for field", ppr sty field_name]