-tcPat (LitPatIn lit@(HsChar str))
- = returnTc (LitPat lit charTy, emptyLIE, charTy)
-
-tcPat (LitPatIn lit@(HsString str))
- = tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
- newMethod (LiteralOrigin lit)
- (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
- let
- comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
- in
- 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)
+tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty
+ -- cf tcExpr on LitLits
+ = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass ->
+ newDicts (LitLitOrigin (unpackFS s))
+ [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ dicts ->
+ returnTc (LitPat (HsLitLit s pat_ty) pat_ty, mkLIE 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 mb_neg) pat_ty
+ = newOverloadedLit origin over_lit pat_ty `thenNF_Tc` \ (pos_lit_expr, lie1) ->
+ newMethodFromName origin pat_ty eqName `thenNF_Tc` \ eq ->
+ (case mb_neg of
+ Nothing -> returnNF_Tc (pos_lit_expr, emptyLIE) -- Positive literal
+ Just neg -> -- Negative literal
+ -- The 'negate' is re-mappable syntax
+ tcLookupId neg `thenNF_Tc` \ neg_sel_id ->
+ newMethod origin neg_sel_id [pat_ty] `thenNF_Tc` \ neg ->
+ returnNF_Tc (HsApp (HsVar (instToId neg)) pos_lit_expr, unitLIE neg)
+ ) `thenNF_Tc` \ (lit_expr, lie2) ->
+
+ returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) lit_expr),
+ lie1 `plusLIE` lie2 `plusLIE` unitLIE eq,
+ emptyBag, emptyBag, emptyLIE)
+ where
+ origin = PatOrigin pat
+
+ -- The literal in an NPatIn is always positive...
+ -- But in NPat, the literal is used to find identical patterns
+ -- so we must negate the literal when necessary!
+ lit' = case (over_lit, mb_neg) of
+ (HsIntegral i _, Nothing) -> HsInteger i
+ (HsIntegral i _, Just _) -> HsInteger (-i)
+ (HsFractional f _, Nothing) -> HsRat f pat_ty
+ (HsFractional f _, Just _) -> HsRat (-f) pat_ty