- 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 = applyTyCon 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] -> [(Class,Type)] -> 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 ->
- let
- data_con = mkDataCon (getName name)
- [NotMarkedStrict]
- [{- No labelled fields -}]
- tyvars
- ctxt
- [] [] -- Temporary
- [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
- 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 ->
+ kc_sig_type = case new_or_data of
+ DataType -> kcHsSigType
+ NewType -> kcHsLiftedSigType
+ -- Can't allow an unlifted type here, because we're effectively
+ -- going to remove the constructor while coercing it to a lifted type.
+
+
+tcConDecls :: NewOrData -> TyCon -> [TyVar] -> ThetaType
+ -> DataConDetails RenamedConDecl -> TcM (DataConDetails DataCon)
+
+tcConDecls new_or_data tycon tyvars ctxt con_decls
+ = case con_decls of
+ Unknown -> returnM Unknown
+ HasCons n -> returnM (HasCons n)
+ DataCons cs -> mappM tc_con_decl cs `thenM` \ data_cons ->
+ returnM (DataCons data_cons)
+ where
+ tc_con_decl (ConDecl name ex_tvs ex_ctxt details src_loc)
+ = addSrcLoc src_loc $
+ tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details) $ \ ex_tyvars ->
+ tcHsTheta ex_ctxt `thenM` \ ex_theta ->
+ case details of
+ PrefixCon btys -> tc_datacon ex_tyvars ex_theta btys
+ InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
+ RecCon fields -> tc_rec_con ex_tyvars ex_theta fields
+ where
+
+ tc_datacon ex_tyvars ex_theta btys
+ = mappM tcHsType (map getBangType btys) `thenM` \ arg_tys ->
+ tcMkDataCon name
+ (map getBangStrictness btys)
+ [{- No field labels -}]
+ tyvars ctxt ex_tyvars ex_theta
+ arg_tys tycon
+
+ 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"