-mkConstructor con_id
- | not (isLocallyDefinedName (getName con_id))
- = returnTc (con_id, EmptyMonoBinds)
-
- | otherwise -- It is locally defined
- = tcInstId con_id `thenNF_Tc` \ (tyvars, theta, tau) ->
- newDicts DataDeclOrigin theta `thenNF_Tc` \ (_, dicts) ->
- let
- (arg_tys, result_ty) = splitFunTy tau
- n_args = length arg_tys
- in
- newLocalIds (take n_args (repeat SLIT("con"))) arg_tys
- `thenNF_Tc` \ args ->
-
- -- Check that all the types of all the strict arguments are in Data.
- -- This is trivially true of everything except type variables, for
- -- which we must check the context.
- let
- strict_marks = dataConStrictMarks con_id
- strict_args = [arg | (arg, MarkedStrict) <- args `zipEqual` strict_marks]
-
- data_tyvars = -- The tyvars in the constructor's context that are arguments
- -- to the Data class
- [getTyVar "mkConstructor" ty
- | (clas,ty) <- theta, uniqueOf clas == evalClassKey]
-
- check_data arg = case getTyVar_maybe (tcIdType arg) of
- Nothing -> returnTc () -- Not a tyvar, so OK
- Just tyvar -> checkTc (tyvar `elem` data_tyvars) (missingDataErr tyvar)
- in
- mapTc check_data strict_args `thenTc_`
-
- -- Build the data constructor
- let
- con_rhs = mkHsTyLam tyvars $
- mkHsDictLam dicts $
- mk_pat_match args $
- mk_case strict_args $
- HsCon con_id (mkTyVarTys tyvars) (map HsVar args)
-
- mk_pat_match [] body = body
- mk_pat_match (arg:args) body = HsLam (PatMatch (VarPat arg) (SimpleMatch (mk_pat_match args body)))
-
- mk_case [] body = body
- mk_case (arg:args) body = HsCase (HsVar arg)
- [PatMatch (VarPat arg) (SimpleMatch (mk_case args body))]
- src_loc
-
- src_loc = nameSrcLoc (getName con_id)
- in
-
- returnTc (con_id, VarMonoBind (RealId con_id) con_rhs)
-\end{code}
-
-We're going to build a record selector that looks like this:
-
- data T a b c = T1 { op :: a, ...}
- | T2 { op :: a, ...}
- | T3
-
- sel :: forall a b c. T a b c -> a
- sel = /\ a b c -> \ T1 { sel = x } -> x
- T2 { sel = 2 } -> x
-
-Note that the selector Id itself is used as the field
-label; it has to be an Id, you see!
-
-\begin{code}
-mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
- = let
- 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
- in
-
- -- Check that all the fields in the group have the same type
- -- This check assumes that all the constructors of a given
- -- data type use the same type variables
- checkTc (all (eqTy field_ty) other_tys)
- (fieldTypeMisMatch field_name) `thenTc_`
+kcConDetails :: NewOrData -> RenamedContext -> ConDetails Name -> TcM ()
+kcConDetails new_or_data ex_ctxt details
+ = kcHsContext ex_ctxt `thenTc_`
+ mapTc_ kc_sig_type (conDetailsTys details)
+ where
+ 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 -> returnTc Unknown
+ HasCons n -> returnTc (HasCons n)
+ DataCons cs -> mapTc tc_con_decl cs `thenTc` \ data_cons ->
+ returnTc (DataCons data_cons)
+ where
+ tc_con_decl (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
+ = tcAddSrcLoc src_loc $
+ tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details) $ \ ex_tyvars ->
+ tcHsTheta ex_ctxt `thenTc` \ ex_theta ->
+ case details of
+ VanillaCon 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
+ = mapTc tcHsType (map getBangType btys) `thenTc` \ arg_tys ->
+ mk_data_con ex_tyvars ex_theta (map getBangStrictness btys) arg_tys []