- 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 boxedTypeKind `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 )
- tcLookupValue 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)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Non-overloaded literals}
-%* *
-%************************************************************************
-
-\begin{code}
-tcPat tc_bndr (LitPatIn lit@(HsChar _)) pat_ty = tcSimpleLitPat lit charTy pat_ty
-tcPat tc_bndr (LitPatIn lit@(HsIntPrim _)) pat_ty = tcSimpleLitPat lit intPrimTy pat_ty
-tcPat tc_bndr (LitPatIn lit@(HsCharPrim _)) pat_ty = tcSimpleLitPat lit charPrimTy pat_ty
-tcPat tc_bndr (LitPatIn lit@(HsStringPrim _)) pat_ty = tcSimpleLitPat lit addrPrimTy pat_ty
-tcPat tc_bndr (LitPatIn lit@(HsFloatPrim _)) pat_ty = tcSimpleLitPat lit floatPrimTy pat_ty
-tcPat tc_bndr (LitPatIn lit@(HsDoublePrim _)) pat_ty = tcSimpleLitPat lit doublePrimTy pat_ty
-
-tcPat tc_bndr (LitPatIn lit@(HsLitLit s)) pat_ty
- -- cf tcExpr on LitLits
- = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
- newDicts (LitLitOrigin (_UNPK_ s))
- [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ (dicts, _) ->
- returnTc (LitPat lit pat_ty, dicts, emptyBag, emptyBag, emptyLIE)