-tcPat (LitPatIn lit@(HsInt i))
- = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
- newOverloadedLit origin
- (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
-
- tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
- newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
-
- returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
- (HsVar over_lit_id)),
- lie1 `plusLIE` lie2,
- tyvar_ty)
- where
- origin = LiteralOrigin lit
-
-tcPat (LitPatIn lit@(HsFrac f))
- = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
- newOverloadedLit origin
- (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
-
- tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
- newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
-
- returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
- (HsVar over_lit_id)),
- lie1 `plusLIE` lie2,
- tyvar_ty)
- where
- origin = LiteralOrigin lit
-
-tcPat (LitPatIn lit@(HsLitLit s))
- = error "tcPat: can't handle ``literal-literal'' patterns"
-
-tcPat (NPlusKPatIn name lit@(HsInt i))
- = tcLookupLocalValueOK "tcPat1:n+k" name `thenNF_Tc` \ local ->
- let
- local_ty = idType local
- in
- tcLookupGlobalValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id ->
- tcLookupGlobalValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id ->
-
- newOverloadedLit origin
- (OverloadedIntegral i) local_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
-
- newMethod origin (RealId ge_sel_id) [local_ty] `thenNF_Tc` \ (lie2, ge_id) ->
- newMethod origin (RealId minus_sel_id) [local_ty] `thenNF_Tc` \ (lie3, minus_id) ->
-
- returnTc (NPlusKPat (TcId local) lit local_ty
- (SectionR (HsVar ge_id) (HsVar over_lit_id))
- (SectionR (HsVar minus_id) (HsVar over_lit_id)),
- lie1 `plusLIE` lie2 `plusLIE` lie3,
- local_ty)
+tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
+ = tc_bndr name pat_ty `thenTc` \ bndr_id ->
+ -- The '-' part is re-mappable syntax
+ tcLookupId minus_name `thenNF_Tc` \ minus_sel_id ->
+ tcLookupGlobalId geName `thenNF_Tc` \ ge_sel_id ->
+ newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
+ newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ ge ->
+ newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ minus ->
+
+ returnTc (NPlusKPat bndr_id i pat_ty
+ (SectionR (HsVar (instToId ge)) over_lit_expr)
+ (SectionR (HsVar (instToId minus)) over_lit_expr),
+ lie1 `plusLIE` mkLIE [ge,minus],
+ emptyBag, unitBag (name, bndr_id), emptyLIE)