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, negateName, minusName, cCallableClassName )
import BasicTypes ( isBoxed )
import Bag
import Outputable
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)
+ tcSyntaxName origin pat_ty negateName neg `thenTc` \ (neg_expr, neg_lie, _) ->
+ returnNF_Tc (HsApp neg_expr pos_lit_expr, neg_lie)
) `thenNF_Tc` \ (lit_expr, lie2) ->
returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) lit_expr),
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 ->
+ tcSyntaxName origin 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