+ tcPat tc_bndr p1 ty1 `thenM` \ (p1', tvs1, ids1, lie_avail1) ->
+ tcPat tc_bndr p2 ty2 `thenM` \ (p2', tvs2, ids2, lie_avail2) ->
+
+ returnM (InfixCon p1' p2',
+ tvs1 `unionBags` tvs2, ids1 `unionBags` ids2,
+ lie_avail1 ++ lie_avail2)
+ where
+ con_arity = dataConSourceArity data_con
+ [ty1, ty2] = arg_tys
+
+tcConStuff tc_bndr data_con (RecCon rpats) arg_tys
+ = -- Check the fields
+ tc_fields field_tys rpats `thenM` \ (rpats', tvs, ids, lie_avail) ->
+ returnM (RecCon rpats', tvs, ids, lie_avail)
+
+ 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) ->