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
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