X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=8b99276c770665192d80e9f2448b29f7a0c0fbc9;hb=f37e239fb5e81fc493e0ea1af98178bf1f7ceaba;hp=0f923ffda58b1549c3ce40484634b9391218db1d;hpb=27897431cf24d4bde04b15947440c7205f2d703c;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 0f923ff..8b99276 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -11,8 +11,8 @@ module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit,
 
 import {-# SOURCE #-}	TcExpr( tcSyntaxOp )
 import HsSyn		( Pat(..), LPat, HsConDetails(..), HsLit(..),
-			  HsOverLit(..), HsExpr(..), OutPat, ExprCoFn(..),
-			  mkCoPat, idCoercion,
+			  HsOverLit(..), HsExpr(..), ExprCoFn(..),
+			  mkCoPat, 
 			  LHsBinds, emptyLHsBinds, isEmptyLHsBinds, 
 			  collectPatsBinders, nlHsLit )
 import TcHsSyn		( TcId, hsLitType )
@@ -21,6 +21,7 @@ import Inst		( InstOrigin(..), shortCutFracLit, shortCutIntLit,
 			  newDictBndrs, instToId, instStupidTheta, isHsVar
 			)
 import Id		( Id, idType, mkLocalId )
+import Var		( CoVar, tyVarKind )
 import CoreFVs		( idFreeTyVars )
 import Name		( Name, mkSystemVarName )
 import TcSimplify	( tcSimplifyCheck, bindInstsOfLocalFuns )
@@ -28,14 +29,15 @@ import TcEnv		( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv2,
 			  tcLookupClass, tcLookupDataCon, refineEnvironment,
 			  tcLookupField, tcMetaTy )
 import TcMType 		( newFlexiTyVarTy, arityErr, tcInstSkolTyVars, 
-			  newCoVars, zonkTcType, tcInstTyVars )
+			  newCoVars, zonkTcType, tcInstTyVars, newBoxyTyVar )
 import TcType		( TcType, TcTyVar, TcSigmaType, TcRhoType, BoxyType,
 			  SkolemInfo(PatSkol), 
 			  BoxySigmaType, BoxyRhoType, argTypeKind, typeKind,
 			  pprSkolTvBinding, isRigidTy, tcTyVarsOfTypes, 
-			  zipTopTvSubst, isArgTypeKind, isUnboxedTupleType,
+			  zipTopTvSubst, isSubArgTypeKind, isUnboxedTupleType,
 			  mkTyVarTys, mkClassPred, isOverloadedTy, substEqSpec,
-			  mkFunTy, mkFunTys, tidyOpenType, tidyOpenTypes )
+			  mkFunTy, mkFunTys, tidyOpenType, tidyOpenTypes,
+			  mkTyVarTy )
 import VarSet		( elemVarSet )
 import {- Kind parts of -} 
        Type		( liftedTypeKind )
@@ -44,11 +46,12 @@ import TcUnify		( boxySplitTyConApp, boxySplitListTy, unBox,
 			  checkSigTyVarsWrt, unifyType )
 import TcHsType		( UserTypeCtxt(..), tcPatSig )
 import TysWiredIn	( boolTy, parrTyCon, tupleTyCon )
+import TcGadt		( Refinement, emptyRefinement, gadtRefine, refineType )
 import Type		( Type, mkTyConApp, substTys, substTheta )
 import StaticFlags	( opt_IrrefutableTuples )
 import TyCon		( TyCon, FieldLabel, tyConFamInst_maybe,
-			  tyConFamilyCoercion_maybe, tyConTyVars, isNewTyCon )
-import DataCon		( DataCon, dataConTyCon, dataConFullSig, dataConName,
+			  tyConFamilyCoercion_maybe, tyConTyVars )
+import DataCon		( DataCon, dataConTyCon, dataConFullSig, 
 			  dataConFieldLabels, dataConSourceArity, 
 			  dataConStupidTheta, dataConUnivTyVars )
 import PrelNames	( integralClassName, fromIntegerName, integerTyConName, 
@@ -227,7 +230,7 @@ unBoxArgType ty pp_this
 	-- but they improve error messages, and allocate fewer tyvars
 	; if isUnboxedTupleType ty' then
 		failWithTc msg
-	  else if isArgTypeKind (typeKind ty') then
+	  else if isSubArgTypeKind (typeKind ty') then
 		return ty'
 	  else do 	-- OpenTypeKind, so constrain it
 	{ ty2 <- newFlexiTyVarTy argTypeKind
@@ -559,7 +562,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 	      arg_tys' = substTys    tenv arg_tys
 
 	; co_vars <- newCoVars eq_spec'	-- Make coercion variables
-	; pstate' <- refineAlt data_con pstate ex_tvs co_vars pat_ty
+	; pstate' <- refineAlt data_con pstate ex_tvs' co_vars pat_ty
 
 	; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
 		tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
@@ -644,6 +647,9 @@ tcConArgs data_con [arg_ty1,arg_ty2] (InfixCon p1 p2) pstate thing_inside
   where
     con_arity  = dataConSourceArity data_con
 
+tcConArgs data_con other_args (InfixCon p1 p2) pstate thing_inside
+  = pprPanic "tcConArgs" (ppr data_con)	-- InfixCon always has two arguments
+
 tcConArgs data_con arg_tys (RecCon rpats) pstate thing_inside
   = do	{ (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
 	; return (RecCon rpats', tvs, res) }
@@ -747,7 +753,10 @@ refineAlt con pstate ex_tvs co_vars pat_ty
 		    -- might be inside a lazy pattern.  Instead, refine pstate
 	        where
 		    
-		    trace_msg = text "refineAlt:match" <+> ppr con <+> ppr reft
+		    trace_msg = text "refineAlt:match" <+> 
+				vcat [ ppr con <+> ppr ex_tvs,
+				       ppr [(v, tyVarKind v) | v <- co_vars],
+				       ppr reft]
 	}
 \end{code}