- returnTc (NPat lit stringTy comp_op, lie, stringTy)
-
-tcPat (LitPatIn lit@(HsIntPrim _))
- = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
-tcPat (LitPatIn lit@(HsCharPrim _))
- = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
-tcPat (LitPatIn lit@(HsStringPrim _))
- = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
-tcPat (LitPatIn lit@(HsFloatPrim _))
- = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
-tcPat (LitPatIn lit@(HsDoublePrim _))
- = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
+
+ -- Check the fields
+ tc_fields field_tys rpats `thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) ->
+
+ returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
+ lie_req,
+ 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) ->
+
+ tcPat tc_bndr rhs_pat pat_ty `thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) ->
+
+ returnTc ((sel_id, rhs_pat', pun_flag) : rpats',
+ lie_req1 `plusLIE` lie_req2,
+ tvs1 `unionBags` tvs2,
+ ids1 `unionBags` ids2,
+ lie_avail1 `plusLIE` lie_avail2)