-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 = tcSimpleLitPat lit intTy pat_ty
- -- This one looks weird!
+tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty
+ -- cf tcExpr on LitLits
+ = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass ->
+ newDicts (LitLitOrigin (_UNPK_ s))
+ [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ (dicts, _) ->
+ returnTc (LitPat (HsLitLit s pat_ty) pat_ty, dicts, emptyBag, emptyBag, emptyLIE)
+
+tcPat tc_bndr pat@(LitPatIn lit@(HsString _)) pat_ty
+ = unifyTauTy pat_ty stringTy `thenTc_`
+ tcLookupGlobalId eqStringName `thenNF_Tc` \ eq_id ->
+ returnTc (NPat lit stringTy (HsVar eq_id `HsApp` HsLit lit),
+ emptyLIE, emptyBag, emptyBag, emptyLIE)
+
+tcPat tc_bndr (LitPatIn simple_lit) pat_ty
+ = unifyTauTy pat_ty (simpleHsLitTy simple_lit) `thenTc_`
+ returnTc (LitPat simple_lit pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
+
+tcPat tc_bndr pat@(NPatIn over_lit) pat_ty
+ = newOverloadedLit (PatOrigin pat) over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
+ tcLookupGlobalId eqName `thenNF_Tc` \ eq_sel_id ->
+ newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ (lie2, eq_id) ->
+
+ returnTc (NPat lit' pat_ty (HsApp (HsVar eq_id) over_lit_expr),
+ lie1 `plusLIE` lie2,
+ emptyBag, emptyBag, emptyLIE)
+ where
+ origin = PatOrigin pat
+ lit' = case over_lit of
+ HsIntegral i _ -> HsInteger i
+ HsFractional f _ -> HsRat f pat_ty