-\begin{code}
-tcConDecl :: TyCon -> [TyVar] -> [(Class,[Type])] -> RenamedConDecl -> TcM s DataCon
-
-tcConDecl tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
- = tcAddSrcLoc src_loc $
- tcExtendTyVarScope ex_tvs $ \ ex_tyvars ->
- tcContext ex_ctxt `thenTc` \ ex_theta ->
- let
- ex_ctxt' = classesOfPreds ex_theta
- in
- tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_ctxt' details
-
-tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_theta details
- = case details of
- VanillaCon btys -> tc_datacon btys
- InfixCon bty1 bty2 -> tc_datacon [bty1,bty2]
- NewCon ty mb_f -> tc_newcon ty mb_f
- RecCon fields -> tc_rec_con fields
- where
- tc_datacon btys
- = let
- arg_stricts = map get_strictness btys
- tys = map get_pty btys
- in
- mapTc tcHsTopType tys `thenTc` \ arg_tys ->
- mk_data_con arg_stricts arg_tys []
-
- tc_newcon ty mb_f
- = tcHsTopBoxedType ty `thenTc` \ arg_ty ->
- -- can't allow an unboxed type here, because we're effectively
- -- going to remove the constructor while coercing it to a boxed type.
- let
- field_label =
- case mb_f of
- Nothing -> []
- Just f -> [mkFieldLabel (getName f) arg_ty (head allFieldLabelTags)]
- in
- mk_data_con [notMarkedStrict] [arg_ty] field_label
-
- tc_rec_con fields
- = checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
- mapTc tc_field fields `thenTc` \ field_label_infos_s ->
- let
- field_label_infos = concat field_label_infos_s
- arg_stricts = [strict | (_, _, strict) <- field_label_infos]
- arg_tys = [ty | (_, ty, _) <- field_label_infos]
-
- field_labels = [ mkFieldLabel (getName name) ty tag
- | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
- in
- mk_data_con arg_stricts arg_tys field_labels
-
- tc_field (field_label_names, bty)
- = tcHsTopType (get_pty bty) `thenTc` \ field_ty ->
- returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
-
- mk_data_con arg_stricts arg_tys fields
- = -- Now we've checked all the field types we must
- -- zonk the existential tyvars to finish the kind
- -- inference on their kinds, and commit them to being
- -- immutable type variables. (The top-level tyvars are
- -- already fixed, by the preceding kind-inference pass.)
- mapNF_Tc zonkTcTyVarToTyVar ex_tyvars `thenNF_Tc` \ ex_tyvars' ->
- zonkTcClassConstraints ex_theta `thenNF_Tc` \ ex_theta' ->
- let
- data_con = mkDataCon name arg_stricts fields
- tyvars (thinContext arg_tys ctxt)
- ex_tyvars' ex_theta'
- arg_tys
- tycon data_con_id data_con_wrap_id
- data_con_id = mkDataConId wkr_name data_con
- data_con_wrap_id = mkDataConWrapId data_con
- in
- returnNF_Tc data_con
-
--- The context for a data constructor should be limited to
--- the type variables mentioned in the arg_tys
-thinContext arg_tys ctxt
- = filter in_arg_tys ctxt
- where
- arg_tyvars = tyVarsOfTypes arg_tys
- in_arg_tys (clas,tys) = not $ isEmptyVarSet $
- tyVarsOfTypes tys `intersectVarSet` arg_tyvars
-
-get_strictness (Banged _) = markedStrict
-get_strictness (Unbanged _) = notMarkedStrict
-get_strictness (Unpacked _) = markedUnboxed
-
-get_pty (Banged ty) = ty
-get_pty (Unbanged ty) = ty
-get_pty (Unpacked ty) = ty
-\end{code}
-