X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=bb9f71e23f58146b04cefecf890167f33fdbacdf;hb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;hp=dfd92d11060486ff05e6879393aacddd0de049b4;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index dfd92d1..bb9f71e 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -16,14 +16,14 @@ import HsSyn		( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
 import RnHsSyn		( RenamedPat(..) )
 import TcHsSyn		( TcPat(..), TcIdOcc(..) )
 
-import TcMonad
+import TcMonad		hiding ( rnMtoTcM )
 import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
 			  emptyLIE, plusLIE, plusLIEs, LIE(..),
 			  newMethod, newOverloadedLit
 			)
 import TcEnv		( tcLookupGlobalValue, tcLookupGlobalValueByKey, 
-			  tcLookupLocalValueOK, tcGlobalOcc )
-import TcType 		( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys )
+			  tcLookupLocalValueOK )
+import TcType 		( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys, tcInstId )
 import Unify 		( unifyTauTy, unifyTauTyList, unifyTauTyLists )
 
 import Bag		( Bag )
@@ -31,12 +31,12 @@ import CmdLineOpts	( opt_IrrefutableTuples )
 import Id		( GenId, idType )
 import Kind		( Kind, mkBoxedTypeKind, mkTypeKind )
 import Maybes		( maybeToBool )
-import Name		( Name )
 import PprType		( GenType, GenTyVar )
 import PrelInfo		( charPrimTy, intPrimTy, floatPrimTy,
 			  doublePrimTy, charTy, stringTy, mkListTy,
 			  mkTupleTy, addrTy, addrPrimTy )
 import Pretty
+import RnHsSyn		( RnName{-instance Outputable-} )
 import Type		( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
 			  getFunTy_maybe, maybeAppDataTyCon,
 			  Type(..), GenType
@@ -72,9 +72,19 @@ tcPat pat_in@(AsPatIn name pat)
     unifyTauTy (idType id) ty		`thenTc_`
     returnTc (AsPat (TcId id) pat', lie, ty)
 
-tcPat (WildPatIn)
+tcPat WildPatIn
   = newTyVarTy mkTypeKind	`thenNF_Tc` \ tyvar_ty ->
     returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
+
+tcPat (NegPatIn pat)
+  = tcPat (negate_lit pat)
+  where
+    negate_lit (LitPatIn (HsInt  i)) = LitPatIn (HsInt  (-i))
+    negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
+    negate_lit _                     = panic "TcPat:negate_pat"
+
+tcPat (ParPatIn parend_pat)
+  = tcPat parend_pat
 \end{code}
 
 %************************************************************************
@@ -161,7 +171,7 @@ tcPat pat_in@(ConPatIn name pats)
 	      lie, 
 	      data_ty)
 
-tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
+tcPat pat_in@(ConOpPatIn pat1 op pat2) 	-- in binary-op form...
   = tcPat pat1				`thenTc` \ (pat1', lie1, ty1) ->
     tcPat pat2				`thenTc` \ (pat2', lie2, ty2) ->
 
@@ -181,26 +191,27 @@ tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
 
 \begin{code}
 tcPat pat_in@(RecPatIn name rpats)
-  = tcGlobalOcc name		`thenNF_Tc` \ (con_id, _, con_rho) ->
+  = tcLookupGlobalValue name		`thenNF_Tc` \ con_id ->
+    tcInstId con_id			`thenNF_Tc` \ (_, _, con_tau) ->
     let
-	(_, con_tau) = splitRhoTy con_rho
 	     -- Ignore the con_theta; overloaded constructors only
 	     -- behave differently when called, not when used for
 	     -- matching.
 	(_, record_ty) = splitFunTy con_tau
     in
 	-- Con is syntactically constrained to be a data constructor
-    ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
+    ASSERT( maybeToBool (maybeAppDataTyCon record_ty) )
 
     mapAndUnzipTc (do_bind record_ty) rpats	`thenTc` \ (rpats', lies) ->
 
-    returnTc (panic "tcPat:RecPatIn:avoid type errors"{-RecPat con_id record_ty rpats', 
+    returnTc (RecPat con_id record_ty rpats', 
 	      plusLIEs lies, 
-	      record_ty-})
+	      record_ty)
 
   where
     do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
-      = tcGlobalOcc field_label		`thenNF_Tc` \ (sel_id, _, tau) ->
+      = tcLookupGlobalValue field_label		`thenNF_Tc` \ sel_id ->
+	tcInstId sel_id				`thenNF_Tc` \ (_, _, tau) ->
 
 		-- Record selectors all have type
 		-- 	forall a1..an.  T a1 .. an -> tau
@@ -313,16 +324,15 @@ tcPats (pat:pats)
 unifies the actual args against the expected ones.
 
 \begin{code}
-matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
+matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
 
 matchConArgTys con arg_tys
-  = tcGlobalOcc con		`thenNF_Tc` \ (con_id, _, con_rho) ->
-    let
-	(con_theta, con_tau) = splitRhoTy con_rho
+  = tcLookupGlobalValue con		`thenNF_Tc` \ con_id ->
+    tcInstId con_id			`thenNF_Tc` \ (_, _, con_tau) ->
 	     -- Ignore the con_theta; overloaded constructors only
 	     -- behave differently when called, not when used for
 	     -- matching.
-
+    let
 	(con_args, con_result) = splitFunTy con_tau
 	con_arity  = length con_args
 	no_of_args = length arg_tys