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, Qualifier, ArithSeqInfo,
20 PolyType, Fake, InPat,
21 Bind(..), MonoBinds(..), Sig,
23 import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..),
24 RnName{-instance Outputable-}
26 import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType,
27 SYN_IE(TcHsBinds), TcIdOcc(..)
29 import Inst ( newDicts, InstOrigin(..), Inst )
30 import TcMonoType ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext )
31 import TcSimplify ( tcSimplifyThetas )
32 import TcType ( tcInstTyVars, tcInstType, tcInstId )
33 import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
34 newLocalId, newLocalIds, tcLookupClassByKey
36 import TcMonad hiding ( rnMtoTcM )
37 import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
39 import PprType ( GenClass, GenType{-instance Outputable-},
40 GenTyVar{-instance Outputable-}{-ToDo:possibly rm-}
42 import Class ( GenClass{-instance Eq-}, classInstEnv )
43 import Id ( mkDataCon, dataConSig, mkRecordSelId, idType,
44 dataConFieldLabels, dataConStrictMarks,
46 GenId{-instance NamedThing-}
49 import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
50 import SpecEnv ( SYN_IE(SpecEnv), nullSpecEnv )
51 import Name ( nameSrcLoc, isLocallyDefinedName, getSrcLoc,
54 import Outputable ( Outputable(..), interpp'SP )
56 import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon,
57 isNewTyCon, isSynTyCon, tyConDataCons
59 import Type ( GenType, -- instances
60 typeKind, getTyVar, tyVarsOfTypes, eqTy, splitSigmaTy,
61 applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
62 splitFunTy, mkTyVarTy, getTyVar_maybe
64 import TyVar ( tyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} )
65 import Unique ( Unique {- instance Eq -}, evalClassKey )
66 import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, SYN_IE(UniqSet) )
67 import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic )
71 tcTyDecl :: RenamedTyDecl -> TcM s TyCon
78 tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
79 = tcAddSrcLoc src_loc $
80 tcAddErrCtxt (tySynCtxt tycon_name) $
83 tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
84 mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
87 tcMonoTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
89 -- Unify tycon kind with (k1->...->kn->rhs)
91 (foldr mkTcArrowKind rhs_kind tyvar_kinds)
94 -- Getting the TyCon's kind is a bit of a nuisance. We can't use the tycon_kind,
95 -- because that's a TcKind and may not yet be fully unified with other kinds.
96 -- We could have augmented the tycon environment with a knot-tied kind,
97 -- but the simplest thing to do seems to be to get the Kind by (lazily)
98 -- looking at the tyvars and rhs_ty.
99 result_kind, final_tycon_kind :: Kind -- NB not TcKind!
100 result_kind = typeKind rhs_ty
101 final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars
103 -- Construct the tycon
104 tycon = mkSynTyCon (getName tycon_name)
113 Algebraic data and newtype decls
114 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
117 tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc)
118 = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
120 tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
121 = tcTyDataOrNew NewType context tycon_name tyvar_names con_decl derivings pragmas src_loc
124 tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
125 = tcAddSrcLoc src_loc $
126 tcAddErrCtxt (tyDataCtxt tycon_name) $
129 tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
130 mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
131 tc_derivs derivings `thenNF_Tc` \ 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 = returnNF_Tc []
160 tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
163 = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
167 Generating constructor/selector bindings for data declarations
168 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
171 mkDataBinds :: [TyCon] -> TcM s ([Id], TcHsBinds s)
172 mkDataBinds [] = returnTc ([], EmptyBinds)
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 `ThenBinds` b2)
179 mkDataBinds_one tycon
180 = ASSERT( isDataTyCon tycon || isNewTyCon tycon )
181 mapAndUnzipTc mkConstructor data_cons `thenTc` \ (con_ids, con_binds) ->
182 mapAndUnzipTc (mkRecordSelector tycon) groups `thenTc` \ (sel_ids, sel_binds) ->
183 returnTc (con_ids ++ sel_ids,
184 SingleBind $ NonRecBind $
186 (foldr AndMonoBinds EmptyMonoBinds sel_binds)
190 data_cons = tyConDataCons tycon
191 fields = [ (con, field) | con <- data_cons,
192 field <- dataConFieldLabels con
195 -- groups is list of fields that share a common name
196 groups = equivClasses cmp_name fields
197 cmp_name (_, field1) (_, field2)
198 = fieldLabelName field1 `cmp` fieldLabelName field2
201 We're going to build a constructor that looks like:
203 data (Data a, C b) => T a b = T1 !a !Int b
206 \d1::Data a, d2::C b ->
207 \p q r -> case p of { p ->
209 HsCon T1 [a,b] [p,q,r]}}
213 * d2 is thrown away --- a context in a data decl is used to make sure
214 one *could* construct dictionaries at the site the constructor
215 is used, but the dictionary isn't actually used.
217 * We have to check that we can construct Data dictionaries for
218 the types a and Int. Once we've done that we can throw d1 away too.
220 * We use (case p of ...) to evaluate p, rather than "seq" because
221 all that matters is that the arguments are evaluated. "seq" is
222 very careful to preserve evaluation order, which we don't need
227 | not (isLocallyDefinedName (getName con_id))
228 = returnTc (con_id, EmptyMonoBinds)
230 | otherwise -- It is locally defined
231 = tcInstId con_id `thenNF_Tc` \ (tc_tyvars, tc_theta, tc_tau) ->
232 newDicts DataDeclOrigin tc_theta `thenNF_Tc` \ (_, dicts) ->
234 (tc_arg_tys, tc_result_ty) = splitFunTy tc_tau
235 n_args = length tc_arg_tys
237 newLocalIds (nOfThem n_args SLIT("con")) tc_arg_tys `thenNF_Tc` \ args ->
239 -- Check that all the types of all the strict arguments are in Eval
240 tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
242 (_,theta,tau) = splitSigmaTy (idType con_id)
243 (arg_tys, _) = splitFunTy tau
244 strict_marks = dataConStrictMarks con_id
245 eval_theta = [ (eval_clas,arg_ty)
246 | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
250 tcSimplifyThetas classInstEnv theta eval_theta `thenTc` \ eval_theta' ->
251 checkTc (null eval_theta')
252 (missingEvalErr con_id eval_theta') `thenTc_`
254 -- Build the data constructor
256 con_rhs = mkHsTyLam tc_tyvars $
259 mk_case (zipEqual "strict_args" args strict_marks) $
260 HsCon con_id (mkTyVarTys tc_tyvars) (map HsVar args)
262 mk_pat_match [] body = body
263 mk_pat_match (arg:args) body = HsLam $
264 PatMatch (VarPat arg) $
265 SimpleMatch (mk_pat_match args body)
267 mk_case [] body = body
268 mk_case ((arg,MarkedStrict):args) body = HsCase (HsVar arg)
269 [PatMatch (VarPat arg) $
270 SimpleMatch (mk_case args body)]
272 mk_case (_:args) body = mk_case args body
274 src_loc = nameSrcLoc (getName con_id)
277 returnTc (con_id, VarMonoBind (RealId con_id) con_rhs)
280 We're going to build a record selector that looks like this:
282 data T a b c = T1 { op :: a, ...}
286 sel :: forall a b c. T a b c -> a
287 sel = /\ a b c -> \ T1 { sel = x } -> x
290 Note that the selector Id itself is used as the field
291 label; it has to be an Id, you see!
294 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
296 field_ty = fieldLabelType first_field_label
297 field_name = fieldLabelName first_field_label
298 other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
299 (tyvars, _, _, _) = dataConSig first_con
300 data_ty = applyTyCon tycon (mkTyVarTys tyvars)
301 -- tyvars of first_con may be free in field_ty
304 -- Check that all the fields in the group have the same type
305 -- This check assumes that all the constructors of a given
306 -- data type use the same type variables
307 checkTc (all (eqTy field_ty) other_tys)
308 (fieldTypeMisMatch field_name) `thenTc_`
310 -- Create an Id for the field itself
311 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
312 tcInstType tenv field_ty `thenNF_Tc` \ field_ty' ->
314 data_ty' = applyTyCon tycon tyvar_tys
316 newLocalId SLIT("x") field_ty' `thenNF_Tc` \ field_id ->
317 newLocalId SLIT("r") data_ty' `thenNF_Tc` \ record_id ->
319 -- Now build the selector
322 selector_ty = mkForAllTys tyvars $
327 selector_id = mkRecordSelId first_field_label selector_ty
329 -- HsSyn is dreadfully verbose for defining the selector!
330 selector_rhs = mkHsTyLam tyvars' $
332 PatMatch (VarPat record_id) $
336 selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
338 mk_match (con_id, field_label)
339 = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
343 returnTc (selector_id, if isLocallyDefinedName (getName tycon)
344 then VarMonoBind (RealId selector_id) selector_rhs
351 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
353 tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
354 = tcDataCon tycon tyvars ctxt name btys src_loc
356 tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
357 = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
359 tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
360 = tcAddSrcLoc src_loc $
361 tcMonoType ty `thenTc` \ arg_ty ->
363 data_con = mkDataCon (getName name)
365 [{- No labelled fields -}]
374 tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
375 = tcAddSrcLoc src_loc $
376 mapTc tcField fields `thenTc` \ field_label_infos_s ->
378 field_label_infos = concat field_label_infos_s
379 stricts = [strict | (_, _, strict) <- field_label_infos]
380 arg_tys = [ty | (_, ty, _) <- field_label_infos]
382 field_labels = [ mkFieldLabel (getName name) ty tag
383 | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
385 data_con = mkDataCon (getName name)
389 (thinContext arg_tys ctxt)
396 tcField (field_label_names, bty)
397 = tcPolyType (get_pty bty) `thenTc` \ field_ty ->
398 returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
400 tcDataCon tycon tyvars ctxt name btys src_loc
401 = tcAddSrcLoc src_loc $
403 stricts = map get_strictness btys
404 tys = map get_pty btys
406 mapTc tcPolyType tys `thenTc` \ arg_tys ->
408 data_con = mkDataCon (getName name)
410 [{- No field labels -}]
412 (thinContext arg_tys ctxt)
419 -- The context for a data constructor should be limited to
420 -- the type variables mentioned in the arg_tys
421 thinContext arg_tys ctxt
422 = filter in_arg_tys ctxt
424 arg_tyvars = tyVarsOfTypes arg_tys
425 in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
427 get_strictness (Banged _) = MarkedStrict
428 get_strictness (Unbanged _) = NotMarkedStrict
430 get_pty (Banged ty) = ty
431 get_pty (Unbanged ty) = ty
439 tySynCtxt tycon_name sty
440 = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
442 tyDataCtxt tycon_name sty
443 = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
445 tyNewCtxt tycon_name sty
446 = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]
448 fieldTypeMisMatch field_name sty
449 = ppSep [ppStr "Declared types differ for field", ppr sty field_name]
451 missingEvalErr con eval_theta sty
452 = ppCat [ppStr "Missing Eval context for constructor",
453 ppQuote (ppr sty con),
454 ppStr ":", ppr sty eval_theta]