- -- Create an Id for the field itself
- tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
- tcInstType tenv field_ty `thenNF_Tc` \ field_ty' ->
- let
- data_ty' = applyTyCon tycon tyvar_tys
- in
- newLocalId SLIT("x") field_ty' `thenNF_Tc` \ field_id ->
- newLocalId SLIT("r") data_ty' `thenNF_Tc` \ record_id ->
-
- -- Now build the selector
- let
- selector_ty :: Type
- selector_ty = mkForAllTys tyvars $
- mkFunTy data_ty $
- field_ty
-
- selector_id :: Id
- selector_id = mkRecordSelId first_field_label selector_ty
-
- -- HsSyn is dreadfully verbose for defining the selector!
- selector_rhs = mkHsTyLam tyvars' $
- HsLam $
- PatMatch (VarPat record_id) $
- SimpleMatch $
- selector_body
-
- selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
-
- mk_match (con_id, field_label)
- = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
- SimpleMatch $
- HsVar field_id
- in
- returnTc (selector_id, if isLocallyDefinedName (getName tycon)
- then VarMonoBind (RealId selector_id) selector_rhs
- else EmptyMonoBinds)
-\end{code}
-
-Constructors
-~~~~~~~~~~~~
-\begin{code}
-tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id
-
-tcConDecl tycon tyvars ctxt (ConDecl name btys src_loc)
- = tcDataCon tycon tyvars ctxt name btys src_loc
-
-tcConDecl tycon tyvars ctxt (ConOpDecl bty1 op bty2 src_loc)
- = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
-
-tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
- = tcAddSrcLoc src_loc $
- tcMonoType ty `thenTc` \ arg_ty ->
- let
- data_con = mkDataCon (getName name)
- [NotMarkedStrict]
- [{- No labelled fields -}]
- tyvars
- ctxt
- [arg_ty]
- tycon
- -- nullSpecEnv
- in
- returnTc data_con
-
-tcConDecl tycon tyvars ctxt (RecConDecl name 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)
- arg_tys
- tycon
- -- nullSpecEnv
- in
- returnTc data_con
-
-tcField (field_label_names, bty)
- = tcPolyType (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 tcPolyType tys `thenTc` \ arg_tys ->
- let
- data_con = mkDataCon (getName name)
- stricts
- [{- No field labels -}]
- tyvars
- (thinContext arg_tys ctxt)
- arg_tys
- tycon
- -- nullSpecEnv
- in
- returnTc data_con
+ tc_rec_con ex_tyvars ex_theta fields
+ = checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
+ mapTc tc_field (fields `zip` allFieldLabelTags) `thenTc` \ field_labels_s ->
+ let
+ field_labels = concat field_labels_s
+ arg_stricts = [str | (ns, bty) <- fields,
+ let str = getBangStrictness bty,
+ n <- ns -- One for each. E.g x,y,z :: !Int
+ ]
+ in
+ mk_data_con ex_tyvars ex_theta arg_stricts
+ (map fieldLabelType field_labels) field_labels
+
+ tc_field ((field_label_names, bty), tag)
+ = tcHsType (getBangType bty) `thenTc` \ field_ty ->
+ returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names]
+
+ mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields
+ = 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