2 % (c) The AQUA Project, Glasgow University, 1996
4 \section[TcTyDecls]{Typecheck type declarations}
7 #include "HsVersions.h"
16 import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), MonoType )
17 import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) )
19 import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext )
20 import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass )
22 import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
24 import Id ( mkDataCon, StrictnessMark(..) )
25 import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
26 import SpecEnv ( SpecEnv(..), nullSpecEnv )
27 import Name ( getNameFullName, Name(..) )
29 import TyCon ( TyCon, ConsVisible(..), NewOrData(..), mkSynTyCon, mkDataTyCon )
30 import Type ( getTypeKind )
31 import TyVar ( getTyVarKind )
37 tcTyDecl :: RenamedTyDecl -> TcM s TyCon
44 tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc)
45 = tcAddSrcLoc src_loc $
46 tcAddErrCtxt (tySynCtxt tycon_name) $
49 tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, rec_tycon) ->
50 mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
53 tcMonoTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
55 -- Unify tycon kind with (k1->...->kn->rhs)
57 (foldr mkTcArrowKind rhs_kind tyvar_kinds)
60 -- Construct the tycon
61 result_kind, final_tycon_kind :: Kind -- NB not TcKind!
62 result_kind = getTypeKind rhs_ty
63 final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars
65 tycon = mkSynTyCon (getItsUnique tycon_name)
66 (getNameFullName tycon_name)
75 Algebraic data and newtype decls
76 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
79 tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc)
80 = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
82 tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
83 = tcTyDataOrNew NewType context tycon_name tyvar_names con_decl derivings pragmas src_loc
86 tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
87 = tcAddSrcLoc src_loc $
88 tcAddErrCtxt (tyDataCtxt tycon_name) $
91 tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, rec_tycon) ->
92 mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
93 tc_derivs derivings `thenNF_Tc` \ derived_classes ->
95 -- Typecheck the context
96 tcContext context `thenTc` \ ctxt ->
98 -- Unify tycon kind with (k1->...->kn->Type)
100 (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
103 mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
104 `thenTc` \ con_ids ->
106 -- Construct the tycon
107 final_tycon_kind :: Kind -- NB not TcKind!
108 final_tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind rec_tyvars
110 tycon = mkDataTyCon (getItsUnique tycon_name)
112 (getNameFullName tycon_name)
117 ConsVisible -- For now; if constrs are from pragma we are *abstract*
122 tc_derivs Nothing = returnNF_Tc []
123 tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
126 = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
134 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
136 tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
137 = tcAddSrcLoc src_loc $
139 (stricts, tys) = sep_bangs btys
141 mapTc tcMonoType tys `thenTc` \ arg_tys ->
143 data_con = mkDataCon (getItsUnique name)
144 (getNameFullName name)
147 [] -- ToDo: ctxt; limited to tyvars in arg_tys
154 tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
155 = tcAddSrcLoc src_loc $
157 (stricts, tys) = sep_bangs [bty1, bty2]
159 mapTc tcMonoType tys `thenTc` \ arg_tys ->
161 data_con = mkDataCon (getItsUnique op)
172 tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
173 = tcAddSrcLoc src_loc $
174 tcMonoType ty `thenTc` \ arg_ty ->
176 data_con = mkDataCon (getItsUnique name)
177 (getNameFullName name)
187 tcConDecl tycon tyvars ctxt (RecConDecl con fields src_loc)
188 = panic "tcConDecls:RecConDecl"
192 = unzip (map sep_bang btys)
194 sep_bang (Banged ty) = (MarkedStrict, ty)
195 sep_bang (Unbanged ty) = (NotMarkedStrict, ty)
203 tySynCtxt tycon_name sty
204 = ppCat [ppStr "In the type declaration for", ppr sty tycon_name]
206 tyDataCtxt tycon_name sty
207 = ppCat [ppStr "In the data declaration for", ppr sty tycon_name]
209 tyNewCtxt tycon_name sty
210 = ppCat [ppStr "In the newtype declaration for", ppr sty tycon_name]