-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, 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) 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` \ eq ->
-
- returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) over_lit_expr),
- lie1 `plusLIE` unitLIE eq,
- emptyBag, emptyBag, emptyLIE)
+tc_pat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty
+ = zapExpectedType pat_ty liftedTypeKind `thenM` \ pat_ty' ->
+ unifyTauTy pat_ty' stringTy `thenM_`
+ tcLookupId eqStringName `thenM` \ eq_id ->
+ returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit),
+ emptyBag, emptyBag, [])
+
+tc_pat tc_bndr (LitPat simple_lit) pat_ty
+ = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' ->
+ unifyTauTy pat_ty' (hsLitType simple_lit) `thenM_`
+ returnM (LitPat simple_lit, emptyBag, emptyBag, [])
+
+tc_pat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
+ = zapExpectedType pat_ty liftedTypeKind `thenM` \ 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, noLoc (HsVar neg)) `thenM` \ (_, neg_expr) ->
+ returnM (mkHsApp neg_expr pos_lit_expr)
+ ) `thenM` \ lit_expr ->
+
+ let
+ -- 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 pat_ty'
+ (HsIntegral i _, Just _) -> HsInteger (-i) pat_ty'
+ (HsFractional f _, Nothing) -> HsRat f pat_ty'
+ (HsFractional f _, Just _) -> HsRat (-f) pat_ty'
+ in
+ returnM (NPatOut lit' pat_ty' (HsApp (nlHsVar eq) lit_expr),
+ emptyBag, emptyBag, [])