import TcMonad
import Inst ( InstOrigin(..),
emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE,
- newMethod, newMethodFromName, newOverloadedLit, newDicts, tcInstDataCon
+ newMethod, newMethodFromName, newOverloadedLit, newDicts,
+ tcInstDataCon, tcSyntaxName
)
import Id ( mkLocalId, mkSysLocal )
import Name ( Name )
import TysWiredIn ( stringTy )
import CmdLineOpts ( opt_IrrefutableTuples )
import DataCon ( dataConFieldLabels, dataConSourceArity )
-import PrelNames ( eqStringName, eqName, geName, cCallableClassName )
+import PrelNames ( eqStringName, eqName, geName, minusName, cCallableClassName )
import BasicTypes ( isBoxed )
import Bag
import Outputable
+import FastString
\end{code}
tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty
-- cf tcExpr on LitLits
= tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass ->
- newDicts (LitLitOrigin (_UNPK_ s))
+ newDicts (LitLitOrigin (unpackFS s))
[mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ dicts ->
returnTc (LitPat (HsLitLit s pat_ty) pat_ty, mkLIE dicts, emptyBag, emptyBag, emptyLIE)
= 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 origin over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
+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 ->
-
- returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) over_lit_expr),
- lie1 `plusLIE` unitLIE 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
- lit' = case over_lit of
- HsIntegral i _ -> HsInteger i
- HsFractional f _ -> HsRat f pat_ty
+
+ -- 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
\end{code}
%************************************************************************
newMethodFromName origin pat_ty geName `thenNF_Tc` \ ge ->
-- The '-' part is re-mappable syntax
- tcLookupId minus_name `thenNF_Tc` \ minus_sel_id ->
- newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ minus ->
+ tcGetInstLoc origin `thenNF_Tc` \ loc ->
+ tcSyntaxName loc pat_ty minusName minus_name `thenTc` \ (minus_expr, minus_lie, _) ->
returnTc (NPlusKPat bndr_id i pat_ty
(SectionR (HsVar (instToId ge)) over_lit_expr)
- (SectionR (HsVar (instToId minus)) over_lit_expr),
- lie1 `plusLIE` lie2 `plusLIE` mkLIE [ge,minus],
+ (SectionR minus_expr over_lit_expr),
+ lie1 `plusLIE` lie2 `plusLIE` minus_lie `plusLIE` unitLIE ge,
emptyBag, unitBag (name, bndr_id), emptyLIE)
where
origin = PatOrigin pat