X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=3ebb7b79a1982d51170848fb3f95237a5de777c0;hb=8053aac536c96dabdc06e9f068852f5481474a29;hp=f165e2e2e02bd2060f5baa0cc12d441f71c1d94b;hpb=6791ad226806d7b4e7618c91516e9e20be882813;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index f165e2e..3ebb7b7 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -21,6 +21,7 @@ import Inst		( InstOrigin(..), shortCutFracLit, shortCutIntLit,
 			  newDictBndrs, instToId, instStupidTheta, isHsVar
 			)
 import Id		( Id, idType, mkLocalId )
+import Var		( CoVar )
 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,10 +46,11 @@ 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 )
+			  tyConFamilyCoercion_maybe, tyConTyVars, isNewTyCon )
 import DataCon		( DataCon, dataConTyCon, dataConFullSig, dataConName,
 			  dataConFieldLabels, dataConSourceArity, 
 			  dataConStupidTheta, dataConUnivTyVars )
@@ -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
@@ -586,6 +589,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
     -- representation tycon.
     --
     boxySplitTyConAppWithFamily tycon pat_ty =
+      traceTc traceMsg >>
       case tyConFamInst_maybe tycon of
         Nothing                   -> boxySplitTyConApp tycon pat_ty
 	Just (fam_tycon, instTys) -> 
@@ -594,6 +598,12 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 	     ; boxyUnifyList (substTys subst instTys) scrutinee_arg_tys
 	     ; return freshTvs
 	     }
+      where
+        traceMsg = sep [ text "tcConPat:boxySplitTyConAppWithFamily:" <+>
+		         ppr tycon <+> ppr pat_ty
+		       , text "  family instance:" <+> 
+			 ppr (tyConFamInst_maybe tycon)
+                       ]
 
     -- Wraps the pattern (which must be a ConPatOut pattern) in a coercion
     -- pattern if the tycon is an instance of a family.
@@ -601,6 +611,8 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
     unwrapFamInstScrutinee :: TyCon -> [Type] -> Pat Id -> Pat Id
     unwrapFamInstScrutinee tycon args pat
       | Just co_con <- tyConFamilyCoercion_maybe tycon 
+--      , not (isNewTyCon tycon)       -- newtypes are explicitly unwrapped by
+				     -- the desugarer
           -- NB: We can use CoPat directly, rather than mkCoPat, as we know the
           --	 coercion is not the identity; mkCoPat is inconvenient as it
           --	 wants a located pattern.