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, DoOrListComp, ArithSeqInfo,
20 HsType, Fake, InPat, HsTyVar, Fixity,
21 Bind(..), MonoBinds(..), Sig
23 import HsTypes ( getTyVarName )
24 import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) )
25 import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType,
26 SYN_IE(TcHsBinds), TcIdOcc(..)
28 import Inst ( newDicts, InstOrigin(..), Inst )
29 import TcMonoType ( tcHsTypeKind, tcHsType, tcContext )
30 import TcSimplify ( tcSimplifyThetas )
31 import TcType ( tcInstTyVars, tcInstType, tcInstId )
32 import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
33 newLocalId, newLocalIds, tcLookupClassByKey
36 import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
38 import PprType ( GenClass, GenType{-instance Outputable-},
39 GenTyVar{-instance Outputable-}{-ToDo:possibly rm-}
41 import CoreUnfold ( getUnfoldingTemplate )
42 import Class ( GenClass{-instance Eq-}, classInstEnv )
43 import Id ( mkDataCon, dataConSig, mkRecordSelId, idType,
44 dataConFieldLabels, dataConStrictMarks,
45 StrictnessMark(..), getIdUnfolding,
46 GenId{-instance NamedThing-}
49 import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
50 import SpecEnv ( SpecEnv, nullSpecEnv )
51 import Name ( nameSrcLoc, isLocallyDefined, getSrcLoc,
52 OccName(..), Name{-instance Ord3-}
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 `thenTc` \ (tycon_kind, _, rec_tycon) ->
84 mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) tyvar_names
85 `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
88 tcHsTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
90 -- Unify tycon kind with (k1->...->kn->rhs)
92 (foldr mkTcArrowKind rhs_kind tyvar_kinds)
95 -- Getting the TyCon's kind is a bit of a nuisance. We can't use the tycon_kind,
96 -- because that's a TcKind and may not yet be fully unified with other kinds.
97 -- We could have augmented the tycon environment with a knot-tied kind,
98 -- but the simplest thing to do seems to be to get the Kind by (lazily)
99 -- looking at the tyvars and rhs_ty.
100 result_kind, final_tycon_kind :: Kind -- NB not TcKind!
101 result_kind = typeKind rhs_ty
102 final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars
104 -- Construct the tycon
105 tycon = mkSynTyCon (getName tycon_name)
114 Algebraic data and newtype decls
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
118 tcTyDecl (TyData context tycon_name tyvar_names con_decls derivings pragmas src_loc)
119 = tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
121 tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
122 = tcTyDataOrNew NewType context tycon_name tyvar_names [con_decl] derivings pragmas src_loc
125 tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
126 = tcAddSrcLoc src_loc $
127 tcAddErrCtxt (tyDataCtxt tycon_name) $
130 tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
131 mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName)
132 tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
133 tc_derivs derivings `thenTc` \ derived_classes ->
135 -- Typecheck the context
136 tcContext context `thenTc` \ ctxt ->
138 -- Unify tycon kind with (k1->...->kn->Type)
140 (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds)
144 mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
145 `thenTc` \ con_ids ->
147 -- Construct the tycon
148 final_tycon_kind :: Kind -- NB not TcKind!
149 final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars
151 tycon = mkDataTyCon (getName tycon_name)
161 tc_derivs Nothing = returnTc []
162 tc_derivs (Just ds) = mapTc tc_deriv ds
165 = tcLookupClass name `thenTc` \ (_, clas) ->
169 Generating constructor/selector bindings for data declarations
170 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
173 mkDataBinds :: [TyCon] -> TcM s ([Id], TcHsBinds s)
174 mkDataBinds [] = returnTc ([], EmptyBinds)
175 mkDataBinds (tycon : tycons)
176 | isSynTyCon tycon = mkDataBinds tycons
177 | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) ->
178 mkDataBinds tycons `thenTc` \ (ids2, b2) ->
179 returnTc (ids1++ids2, b1 `ThenBinds` b2)
181 mkDataBinds_one tycon
182 = ASSERT( isDataTyCon tycon || isNewTyCon tycon )
183 mapTc checkConstructorContext data_cons `thenTc_`
184 mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
186 data_ids = data_cons ++ sel_ids
188 -- For the locally-defined things
189 -- we need to turn the unfoldings inside the Ids into bindings,
190 binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id))
191 | data_id <- data_ids, isLocallyDefined data_id
195 SingleBind (NonRecBind (foldr AndMonoBinds EmptyMonoBinds binds))
198 data_cons = tyConDataCons tycon
199 fields = [ (con, field) | con <- data_cons,
200 field <- dataConFieldLabels con
203 -- groups is list of fields that share a common name
204 groups = equivClasses cmp_name fields
205 cmp_name (_, field1) (_, field2)
206 = fieldLabelName field1 `cmp` fieldLabelName field2
209 -- Check that all the types of all the strict arguments are in Eval
212 checkConstructorContext con_id
213 | not (isLocallyDefined con_id)
216 | otherwise -- It is locally defined
217 = tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
219 strict_marks = dataConStrictMarks con_id
220 (tyvars,theta,tau) = splitSigmaTy (idType con_id)
221 (arg_tys, result_ty) = splitFunTy tau
223 eval_theta = [ (eval_clas,arg_ty)
224 | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
228 tcSimplifyThetas classInstEnv theta eval_theta `thenTc` \ eval_theta' ->
229 checkTc (null eval_theta')
230 (missingEvalErr con_id eval_theta')
234 mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
235 -- These fields all have the same name, but are from
236 -- different constructors in the data type
237 -- Check that all the fields in the group have the same type
238 -- This check assumes that all the constructors of a given
239 -- data type use the same type variables
240 = checkTc (all (eqTy field_ty) other_tys)
241 (fieldTypeMisMatch field_name) `thenTc_`
244 field_ty = fieldLabelType first_field_label
245 field_name = fieldLabelName first_field_label
246 other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
247 (tyvars, _, _, _) = dataConSig first_con
248 data_ty = applyTyCon tycon (mkTyVarTys tyvars)
249 -- tyvars of first_con may be free in field_ty
250 -- Now build the selector
253 selector_ty = mkForAllTys tyvars $
258 selector_id = mkRecordSelId first_field_label selector_ty
264 tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
266 tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
267 = tcDataCon tycon tyvars ctxt name btys src_loc
269 tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
270 = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
272 tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
273 = tcAddSrcLoc src_loc $
274 tcHsType ty `thenTc` \ arg_ty ->
276 data_con = mkDataCon (getName name)
278 [{- No labelled fields -}]
287 tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc)
288 = tcAddSrcLoc src_loc $
289 mapTc tcField fields `thenTc` \ field_label_infos_s ->
291 field_label_infos = concat field_label_infos_s
292 stricts = [strict | (_, _, strict) <- field_label_infos]
293 arg_tys = [ty | (_, ty, _) <- field_label_infos]
295 field_labels = [ mkFieldLabel (getName name) ty tag
296 | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
298 data_con = mkDataCon (getName name)
302 (thinContext arg_tys ctxt)
309 tcField (field_label_names, bty)
310 = tcHsType (get_pty bty) `thenTc` \ field_ty ->
311 returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
313 tcDataCon tycon tyvars ctxt name btys src_loc
314 = tcAddSrcLoc src_loc $
316 stricts = map get_strictness btys
317 tys = map get_pty btys
319 mapTc tcHsType tys `thenTc` \ arg_tys ->
321 data_con = mkDataCon (getName name)
323 [{- No field labels -}]
325 (thinContext arg_tys ctxt)
332 -- The context for a data constructor should be limited to
333 -- the type variables mentioned in the arg_tys
334 thinContext arg_tys ctxt
335 = filter in_arg_tys ctxt
337 arg_tyvars = tyVarsOfTypes arg_tys
338 in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
340 get_strictness (Banged _) = MarkedStrict
341 get_strictness (Unbanged _) = NotMarkedStrict
343 get_pty (Banged ty) = ty
344 get_pty (Unbanged ty) = ty
352 tySynCtxt tycon_name sty
353 = ppCat [ppPStr SLIT("In the type declaration for"), ppr sty tycon_name]
355 tyDataCtxt tycon_name sty
356 = ppCat [ppPStr SLIT("In the data declaration for"), ppr sty tycon_name]
358 tyNewCtxt tycon_name sty
359 = ppCat [ppPStr SLIT("In the newtype declaration for"), ppr sty tycon_name]
361 fieldTypeMisMatch field_name sty
362 = ppSep [ppPStr SLIT("Declared types differ for field"), ppr sty field_name]
364 missingEvalErr con eval_theta sty
365 = ppCat [ppPStr SLIT("Missing Eval context for constructor"),
366 ppQuote (ppr sty con),
367 ppChar ':', ppr sty eval_theta]