X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=291d85498531d9decae8c4faa56a115842c2d817;hb=259be9ef2ecc354d52622479921634606d6d2832;hp=548f710b3d4d577ba80c2f6bb059e343e365ea7b;hpb=52671283f2c6b313a9d81e7ceb6b849415e6a76a;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 548f710..291d854 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -17,7 +17,8 @@ import TcHsSyn		( TcPat, TcId, simpleHsLitTy )
 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 )
@@ -35,7 +36,7 @@ import TcMonoType	( tcHsSigType, UserTypeCtxt(..) )
 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
@@ -313,9 +314,8 @@ tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
 	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),
@@ -347,13 +347,12 @@ tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
     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