+ = tcLookupClass cCallableClassName `thenM` \ cCallableClass ->
+ newDicts (LitLitOrigin (unpackFS s))
+ [mkClassPred cCallableClass [pat_ty]] `thenM` \ dicts ->
+ extendLIEs dicts `thenM_`
+ returnM (LitPat (HsLitLit s pat_ty), emptyBag, emptyBag, [])
+
+tcPat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty
+ = unifyTauTy pat_ty stringTy `thenM_`
+ tcLookupId eqStringName `thenM` \ eq_id ->
+ returnM (NPatOut lit stringTy (HsVar eq_id `HsApp` HsLit lit),
+ emptyBag, emptyBag, [])
+
+tcPat tc_bndr (LitPat simple_lit) pat_ty
+ = unifyTauTy pat_ty (hsLitType simple_lit) `thenM_`
+ returnM (LitPat simple_lit, emptyBag, emptyBag, [])
+
+tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
+ = newOverloadedLit origin over_lit pat_ty `thenM` \ pos_lit_expr ->
+ newMethodFromName origin pat_ty eqName `thenM` \ eq ->
+ (case mb_neg of
+ Nothing -> returnM pos_lit_expr -- Positive literal
+ Just neg -> -- Negative literal
+ -- The 'negate' is re-mappable syntax
+ tcSyntaxName origin pat_ty negateName neg `thenM` \ (neg_expr, _) ->
+ returnM (HsApp neg_expr pos_lit_expr)
+ ) `thenM` \ lit_expr ->
+
+ returnM (NPatOut lit' pat_ty (HsApp (HsVar eq) lit_expr),
+ emptyBag, emptyBag, [])
+ 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