X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=e5bfc93ea7eeb93ac8159ac6d63434ea33a1319e;hb=5792b355352b5e2112cffdbbd413ead8b6be7bdf;hp=882af01d2f4827eb644cf1e5dfad4d049a80c28b;hpb=20d387c481324aed48e8469d3fbf0695b3b2e365;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 882af01..e5bfc93 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -4,7 +4,7 @@
 \section[TcPat]{Typechecking patterns}
 
 \begin{code}
-module TcPat ( tcPat, tcPatBndr_NoSigs, simpleHsLitTy, badFieldCon, polyPatSig ) where
+module TcPat ( tcPat, tcMonoPatBndr, simpleHsLitTy, badFieldCon, polyPatSig ) where
 
 #include "HsVersions.h"
 
@@ -14,12 +14,13 @@ import TcHsSyn		( TcPat, TcId )
 
 import TcMonad
 import Inst		( InstOrigin(..),
-			  emptyLIE, plusLIE, LIE,
+			  emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId,
 			  newMethod, newOverloadedLit, newDicts, newClassDicts
 			)
-import Name		( Name, getOccName, getSrcLoc )
+import Id		( mkVanillaId )
+import Name		( Name )
 import FieldLabel	( fieldLabelName )
-import TcEnv		( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, newLocalId )
+import TcEnv		( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupSyntaxId )
 import TcType 		( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
 import TcMonoType	( tcHsSigType )
 import TcUnify 		( unifyTauTy, unifyListTy, unifyTupleTy	)
@@ -34,7 +35,7 @@ import TysPrim		( charPrimTy, intPrimTy, floatPrimTy,
 			  doublePrimTy, addrPrimTy
 			)
 import TysWiredIn	( charTy, stringTy, intTy, integerTy )
-import PrelNames	( eqStringName, eqName, geName, cCallableClassName )
+import PrelNames	( minusName, eqStringName, eqName, geName, cCallableClassName )
 import BasicTypes	( isBoxed )
 import Bag
 import Outputable
@@ -48,14 +49,10 @@ import Outputable
 %************************************************************************
 
 \begin{code}
--- This is the right function to pass to tcPat when there are no signatures
-tcPatBndr_NoSigs binder_name pat_ty
-  =  	-- Need to make a new, monomorphic, Id
-	-- The binder_name is already being used for the polymorphic Id
-     newLocalId (getOccName binder_name) pat_ty loc	`thenNF_Tc` \ bndr_id ->
-     returnTc bndr_id
- where
-   loc = getSrcLoc binder_name
+-- This is the right function to pass to tcPat when 
+-- we're looking at a lambda-bound pattern, 
+-- so there's no polymorphic guy to worry about
+tcMonoPatBndr binder_name pat_ty = returnTc (mkVanillaId binder_name pat_ty)
 \end{code}
 
 
@@ -264,8 +261,8 @@ 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, dicts, emptyBag, emptyBag, emptyLIE)
+	     [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_` 
@@ -280,16 +277,16 @@ tcPat tc_bndr (LitPatIn simple_lit) pat_ty
 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` \ (lie2, eq_id) ->
+    newMethod origin eq_sel_id [pat_ty]			`thenNF_Tc` \ eq ->
 
-    returnTc (NPat lit' pat_ty (HsApp (HsVar eq_id) over_lit_expr),
-	      lie1 `plusLIE` lie2,
+    returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) over_lit_expr),
+	      lie1 `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
+		HsIntegral i   -> HsInteger i
+		HsFractional f -> HsRat f pat_ty
 \end{code}
 
 %************************************************************************
@@ -299,18 +296,19 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty
 %************************************************************************
 
 \begin{code}
-tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus) pat_ty
+tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i)) pat_ty
   = tc_bndr name pat_ty				`thenTc` \ bndr_id ->
-    tcLookupGlobalId minus			`thenNF_Tc` \ minus_sel_id ->
+	-- The '-' part is re-mappable syntax
+    tcLookupSyntaxId minusName			`thenNF_Tc` \ minus_sel_id ->
     tcLookupGlobalId geName			`thenNF_Tc` \ ge_sel_id ->
     newOverloadedLit origin lit pat_ty		`thenNF_Tc` \ (over_lit_expr, lie1) ->
-    newMethod origin ge_sel_id    [pat_ty]	`thenNF_Tc` \ (lie2, ge_id) ->
-    newMethod origin minus_sel_id [pat_ty]	`thenNF_Tc` \ (lie3, minus_id) ->
+    newMethod origin ge_sel_id    [pat_ty]	`thenNF_Tc` \ ge ->
+    newMethod origin minus_sel_id [pat_ty]	`thenNF_Tc` \ minus ->
 
     returnTc (NPlusKPat bndr_id i pat_ty
-			(SectionR (HsVar ge_id) over_lit_expr)
-			(SectionR (HsVar minus_id) over_lit_expr),
-	      lie1 `plusLIE` lie2 `plusLIE` lie3,
+			(SectionR (HsVar (instToId ge)) over_lit_expr)
+			(SectionR (HsVar (instToId minus)) over_lit_expr),
+	      lie1 `plusLIE` mkLIE [ge,minus],
 	      emptyBag, unitBag (name, bndr_id), emptyLIE)
   where
     origin = PatOrigin pat
@@ -381,12 +379,12 @@ tcConstructor pat con_name pat_ty
 	ex_tvs'   = take n_ex_tvs all_tvs'
 	result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
     in
-    newClassDicts (PatOrigin pat) ex_theta'	`thenNF_Tc` \ (lie_avail, dicts) ->
+    newClassDicts (PatOrigin pat) ex_theta'	`thenNF_Tc` \ dicts ->
 
 	-- Check overall type matches
     unifyTauTy pat_ty result_ty		`thenTc_`
 
-    returnTc (data_con, ex_tvs', dicts, lie_avail, arg_tys')
+    returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys')
 \end{code}	      
 
 ------------------------------------------------------