+ where
+ field_tys = zip (map fieldLabelName (dataConFieldLabels data_con)) arg_tys
+ -- Don't use zipEqual! If the constructor isn't really a record, then
+ -- dataConFieldLabels will be empty (and each field in the pattern
+ -- will generate an error below).
+
+ tc_fields field_tys []
+ = returnM ([], emptyBag, emptyBag, [])
+
+ tc_fields field_tys ((field_label, rhs_pat) : rpats)
+ = tc_fields field_tys rpats `thenM` \ (rpats', tvs1, ids1, lie_avail1) ->
+
+ (case [ty | (f,ty) <- field_tys, f == field_label] of
+
+ -- No matching field; chances are this field label comes from some
+ -- other record type (or maybe none). As well as reporting an
+ -- error we still want to typecheck the pattern, principally to
+ -- make sure that all the variables it binds are put into the
+ -- environment, else the type checker crashes later:
+ -- f (R { foo = (a,b) }) = a+b
+ -- If foo isn't one of R's fields, we don't want to crash when
+ -- typechecking the "a+b".
+ [] -> addErrTc (badFieldCon data_con field_label) `thenM_`
+ newTyVarTy liftedTypeKind `thenM` \ bogus_ty ->
+ returnM (error "Bogus selector Id", bogus_ty)
+
+ -- The normal case, when the field comes from the right constructor
+ (pat_ty : extras) ->
+ ASSERT( null extras )
+ tcLookupId field_label `thenM` \ sel_id ->
+ returnM (sel_id, pat_ty)
+ ) `thenM` \ (sel_id, pat_ty) ->
+
+ tcPat tc_bndr rhs_pat (Check pat_ty) `thenM` \ (rhs_pat', tvs2, ids2, lie_avail2) ->
+
+ returnM ((sel_id, rhs_pat') : rpats',
+ tvs1 `unionBags` tvs2,
+ ids1 `unionBags` ids2,
+ lie_avail1 ++ lie_avail2)