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

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index dfd92d1..becc2d6 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -8,22 +8,23 @@
 
 module TcPat ( tcPat ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
 import HsSyn		( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
-			  Match, HsBinds, Qual, PolyType,
+			  Match, HsBinds, Qualifier, PolyType,
 			  ArithSeqInfo, Stmt, Fake )
-import RnHsSyn		( RenamedPat(..) )
-import TcHsSyn		( TcPat(..), TcIdOcc(..) )
+import RnHsSyn		( SYN_IE(RenamedPat), RnName{-instance Outputable-} )
+import TcHsSyn		( SYN_IE(TcPat), TcIdOcc(..) )
 
-import TcMonad
+import TcMonad		hiding ( rnMtoTcM )
 import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
-			  emptyLIE, plusLIE, plusLIEs, LIE(..),
+			  emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
 			  newMethod, newOverloadedLit
 			)
 import TcEnv		( tcLookupGlobalValue, tcLookupGlobalValueByKey, 
-			  tcLookupLocalValueOK, tcGlobalOcc )
-import TcType 		( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys )
+			  tcLookupLocalValueOK )
+import SpecEnv		( SpecEnv )
+import TcType 		( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
 import Unify 		( unifyTauTy, unifyTauTyList, unifyTauTyLists )
 
 import Bag		( Bag )
@@ -31,19 +32,20 @@ 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 PprStyle--ToDo:rm
 import Pretty
 import Type		( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
 			  getFunTy_maybe, maybeAppDataTyCon,
-			  Type(..), GenType
+			  SYN_IE(Type), GenType
 			)
 import TyVar		( GenTyVar )
+import TysPrim		( charPrimTy, intPrimTy, floatPrimTy,
+			  doublePrimTy, addrPrimTy
+			)
+import TysWiredIn	( charTy, stringTy, mkListTy, mkTupleTy, addrTy )
 import Unique		( Unique, eqClassOpKey )
-import Util		( assertPanic, panic{-ToDo:rm-} )
+import Util		( assertPanic, panic )
 \end{code}
 
 \begin{code}
@@ -58,7 +60,7 @@ tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
 
 \begin{code}
 tcPat (VarPatIn name)
-  = tcLookupLocalValueOK "tcPat1" name	`thenNF_Tc` \ id ->
+  = tcLookupLocalValueOK ("tcPat1:"{-++ppShow 80 (ppr PprDebug name)-}) name	`thenNF_Tc` \ id ->
     returnTc (VarPat (TcId id), emptyLIE, idType id)
 
 tcPat (LazyPatIn pat)
@@ -72,9 +74,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 +173,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 +193,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 +326,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
@@ -330,7 +342,7 @@ matchConArgTys con arg_tys
     checkTc (con_arity == no_of_args)
 	    (arityErr "Constructor" con_id con_arity no_of_args)	`thenTc_`
 
-    unifyTauTyLists arg_tys con_args	 				`thenTc_`
+    unifyTauTyLists con_args arg_tys	 				`thenTc_`
     returnTc (con_id, con_result)
 \end{code}