- -- Check the constructor itself
- tcConstructor pat name `thenTc` \ (data_con, lie_req1, ex_tvs, ex_dicts, lie_avail1, arg_tys, con_res_ty) ->
-
- -- Check overall type matches (c.f. tcConPat)
- tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req2) ->
- let
- -- 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).
- field_tys = zip (map fieldLabelName (dataConFieldLabels data_con))
- arg_tys
- in
-
- -- Check the fields
- tc_fields field_tys rpats `thenTc` \ (rpats', lie_req3, tvs, ids, lie_avail2) ->
-
- returnTc (RecPat data_con pat_ty ex_tvs ex_dicts rpats',
- lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3,
- listToBag ex_tvs `unionBags` tvs,
- ids,
- lie_avail1 `plusLIE` lie_avail2)
-
- where
- tc_fields field_tys []
- = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
-
- tc_fields field_tys ((field_label, rhs_pat, pun_flag) : rpats)
- = tc_fields field_tys rpats `thenTc` \ (rpats', lie_req1, 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 name field_label) `thenNF_Tc_`
- newTyVarTy liftedTypeKind `thenNF_Tc_`
- returnTc (error "Bogus selector Id", pat_ty)
-
- -- The normal case, when the field comes from the right constructor
- (pat_ty : extras) ->
- ASSERT( null extras )
- tcLookupGlobalId field_label `thenNF_Tc` \ sel_id ->
- returnTc (sel_id, pat_ty)
- ) `thenTc` \ (sel_id, pat_ty) ->