- -- 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
- tycon_src_loc = getSrcLoc tycon
-
- selector_ty = mkForAllTys tyvars' $
- mkFunTy data_ty' $
- field_ty'
-
- 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) $
- GRHSMatch $
- GRHSsAndBindsOut [OtherwiseGRHS selector_body tycon_src_loc]
- EmptyBinds field_ty'
-
- selector_body = HsCase (HsVar record_id) (map mk_match fields) tycon_src_loc
-
- mk_match (con_id, field_label)
- = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
- GRHSMatch $
- GRHSsAndBindsOut [OtherwiseGRHS (HsVar field_id)
- (getSrcLoc (fieldLabelName field_label))]
- EmptyBinds
- field_ty'
- in
- returnTc (selector_id, VarMonoBind selector_id selector_rhs)
--}
-\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)
- = tcMonoType (get_ty 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_ty btys
- in
- mapTc tcMonoType tys `thenTc` \ arg_tys ->
+ tc_rec_con ex_tyvars ex_theta fields
+ = checkTc (null ex_tyvars) (exRecConErr name) `thenM_`
+ mappM tc_field (fields `zip` allFieldLabelTags) `thenM` \ field_labels ->
+ let
+ arg_stricts = [getBangStrictness bty | (n, bty) <- fields]
+ arg_tys = map fieldLabelType field_labels
+ in
+ tcMkDataCon name arg_stricts field_labels
+ tyvars ctxt ex_tyvars ex_theta
+ arg_tys tycon
+
+ tc_field ((field_label_name, bty), tag)
+ = tcHsType (getBangType bty) `thenM` \ field_ty ->
+ returnM (mkFieldLabel field_label_name tycon field_ty tag)
+
+tcMkDataCon :: Name
+ -> [StrictnessMark] -> [FieldLabel]
+ -> [TyVar] -> ThetaType
+ -> [TyVar] -> ThetaType
+ -> [Type] -> TyCon
+ -> TcM DataCon
+-- A wrapper for DataCon.mkDataCon that
+-- a) makes the worker Id
+-- b) makes the wrapper Id if necessary, including
+-- allocating its unique (hence monadic)
+tcMkDataCon src_name arg_stricts fields
+ tyvars ctxt ex_tyvars ex_theta
+ arg_tys tycon
+ = lookupSysName src_name mkDataConWrapperOcc `thenM` \ wrap_name ->
+ lookupSysName src_name mkDataConWorkerOcc `thenM` \ work_name ->
+ -- This last one takes the name of the data constructor in the source
+ -- code, which (for Haskell source anyway) will be in the SrcDataName name
+ -- space, and makes it into a "real data constructor name"