- tc_sig (SpecDataSig n ty src_loc)
- = addSrcLocB_Tc src_loc (
- let
- ty_names = extractMonoTyNames (==) ty
- (tve,_,_) = mkTVE ty_names
- fake_CE = panic "tcSpecDataSigs:CE"
- in
- -- Typecheck specialising type (includes arity check)
- tcMonoType fake_CE tce tve ty `thenB_Tc` \ tau_ty ->
- let
- (_,ty_args,_) = getUniDataTyCon tau_ty
- is_unboxed_or_tyvar ty = isUnboxedDataType ty || isTyVarTemplateTy ty
- in
- -- Check at least one unboxed type in specialisation
- checkB_Tc (not (any isUnboxedDataType ty_args))
- (specDataNoSpecErr n ty_args src_loc) `thenB_Tc_`
-
- -- Check all types are unboxed or tyvars
- -- (specific boxed types are redundant)
- checkB_Tc (not (all is_unboxed_or_tyvar ty_args))
- (specDataUnboxedErr n ty_args src_loc) `thenB_Tc_`
-
- let
- maybe_tys = specialiseConstrTys ty_args
- in
- returnB_Tc (SpecInfo maybe_tys 0 (panic "SpecData:SpecInfo:SpecId"))
- )
-
-tcSpecDataSigs tce [] accum
- = -- Remove any duplicates from accumulated specinfos
- getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr ->
-
- (if sw_chkr SpecialiseTrace && not (null duplicates) then
- pprTrace "Duplicate SPECIALIZE data pragmas:\n"
- (ppAboves (map specmsg sep_dups))
- else id)(
-
- (if sw_chkr SpecialiseTrace && not (null spec_infos) then
- pprTrace "Specialising "
- (ppHang (ppCat [ppr PprDebug name, ppStr "at types:"])
- 4 (ppAboves (map pp_spec spec_infos)))
-
- else id) (
-
- returnB_Tc (spec_infos)
- ))
+ field_ty = fieldLabelType first_field_label
+ field_name = fieldLabelName first_field_label
+ other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
+ (tyvars, _, _, _, _, _) = dataConSig first_con
+ data_ty = mkTyConApp tycon (mkTyVarTys tyvars)
+ -- tyvars of first_con may be free in field_ty
+ -- Now build the selector
+
+ selector_ty :: Type
+ selector_ty = mkForAllTys tyvars $
+ mkFunTy data_ty $
+ field_ty
+
+ selector_id :: Id
+ selector_id = mkRecordSelId first_field_label selector_ty
+\end{code}
+
+Constructors
+~~~~~~~~~~~~
+\begin{code}
+tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s Id
+
+tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc)
+ = tcDataCon tycon tyvars ctxt name btys src_loc
+
+tcConDecl tycon tyvars ctxt (ConDecl op ex_ctxt (InfixCon bty1 bty2) src_loc)
+ = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
+
+tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc)
+ = tcAddSrcLoc src_loc $
+ tcHsType 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.
+ checkTc (not (isUnboxedType arg_ty)) (newTypeUnboxedField ty) `thenTc_`
+ let
+ data_con = mkDataCon (getName name)
+ [NotMarkedStrict]
+ [{- No labelled fields -}]
+ tyvars
+ ctxt
+ [] [] -- Temporary; existential chaps
+ [arg_ty]
+ tycon
+ in
+ returnTc data_con
+
+tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc)
+ = tcAddSrcLoc src_loc $
+ mapTc tcField fields `thenTc` \ field_label_infos_s ->
+ let
+ field_label_infos = concat field_label_infos_s
+ 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 ]
+
+ data_con = mkDataCon (getName name)
+ stricts
+ field_labels
+ tyvars
+ (thinContext arg_tys ctxt)
+ [] [] -- Temporary; existential chaps
+ arg_tys
+ tycon
+ in
+ returnTc data_con
+
+tcField (field_label_names, bty)
+ = tcHsType (get_pty bty) `thenTc` \ field_ty ->
+ returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
+
+tcDataCon tycon tyvars ctxt name btys src_loc
+ = tcAddSrcLoc src_loc $
+ let
+ stricts = map get_strictness btys
+ tys = map get_pty btys
+ in
+ mapTc tcHsType tys `thenTc` \ arg_tys ->
+ let
+ data_con = mkDataCon (getName name)
+ stricts
+ [{- No field labels -}]
+ tyvars
+ (thinContext arg_tys ctxt)
+ [] [] -- Temporary existential chaps
+ arg_tys
+ tycon
+ in
+ returnTc 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