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

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 16b0ca2..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 )
-import TcType 		( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys, tcInstId )
+import SpecEnv		( SpecEnv )
+import TcType 		( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
 import Unify 		( unifyTauTy, unifyTauTyList, unifyTauTyLists )
 
 import Bag		( Bag )
@@ -32,18 +33,19 @@ import Id		( GenId, idType )
 import Kind		( Kind, mkBoxedTypeKind, mkTypeKind )
 import Maybes		( maybeToBool )
 import PprType		( GenType, GenTyVar )
-import PrelInfo		( charPrimTy, intPrimTy, floatPrimTy,
-			  doublePrimTy, charTy, stringTy, mkListTy,
-			  mkTupleTy, addrTy, addrPrimTy )
+--import PprStyle--ToDo:rm
 import Pretty
-import RnHsSyn		( RnName{-instance Outputable-} )
 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) ->
 
@@ -190,13 +202,13 @@ tcPat pat_in@(RecPatIn name rpats)
 	(_, 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)
@@ -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}