X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=9261ecb58c7e794f8b377bbd6a4ab08f378b5476;hb=6c3c61e070a52231887db1cdc3a35bec021dcf42;hp=51d68bb9fd946a073ac5498616cf56f8708be74c;hpb=20e39e0e07e4a8e9395894b2785d6675e4e3e3b3;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 51d68bb..9261ecb 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -18,14 +18,15 @@ import Inst		( InstOrigin(..),
 			  instToId, tcInstStupidTheta, tcSyntaxName
 			)
 import Id		( Id, idType, mkLocalId )
+import Var		( tyVarName )
 import Name		( Name )
 import TcSimplify	( tcSimplifyCheck, bindInstsOfLocalFuns )
-import TcEnv		( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv3,
+import TcEnv		( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv2,
 			  tcLookupClass, tcLookupDataCon, tcLookupId )
 import TcMType 		( newTyFlexiVarTy, arityErr, tcSkolTyVars, readMetaTyVar )
 import TcType		( TcType, TcTyVar, TcSigmaType, TcTauType, zipTopTvSubst,
-			  SkolemInfo(PatSkol), isSkolemTyVar, pprSkolemTyVar, 
-			  TvSubst, mkTvSubst, substTyVar, substTy, MetaDetails(..),
+			  SkolemInfo(PatSkol), isSkolemTyVar, isMetaTyVar, pprSkolemTyVar, 
+			  TvSubst, mkOpenTvSubst, substTyVar, substTy, MetaDetails(..),
 			  mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy )
 import VarEnv		( mkVarEnv )	-- ugly
 import Kind		( argTypeKind, liftedTypeKind )
@@ -33,7 +34,7 @@ import TcUnify		( tcSubPat, Expected(..), zapExpectedType,
 			  zapExpectedTo, zapToListTy, zapToTyConApp )  
 import TcHsType		( UserTypeCtxt(..), TcSigInfo( sig_tau ), TcSigFun, tcHsPatSigType )
 import TysWiredIn	( stringTy, parrTyCon, tupleTyCon )
-import Unify		( MaybeErr(..), gadtRefineTys, gadtMatchTys )
+import Unify		( MaybeErr(..), gadtRefineTys, BindFlag(..) )
 import Type		( substTys, substTheta )
 import CmdLineOpts	( opt_IrrefutableTuples )
 import TyCon		( TyCon )
@@ -117,15 +118,12 @@ tcCheckPats ctxt pats tys thing_inside 	-- A trivial wrapper
 %************************************************************************
 
 \begin{code}
-data PatCtxt = LamPat Bool 	-- Used for lambda, case, do-notation etc
+data PatCtxt = LamPat 		-- Used for lambda, case, do-notation etc
 	     | LetPat TcSigFun	-- Used for let(rec) bindings
-	-- True <=> we are checking the case expression, 
-	--		so can do full-blown refinement
-	-- False <=> inferring, do no refinement
 
 -------------------
 tcPatBndr :: PatCtxt -> Name -> Expected TcSigmaType -> TcM TcId
-tcPatBndr (LamPat _) bndr_name pat_ty
+tcPatBndr LamPat bndr_name pat_ty
   = do	{ pat_ty' <- zapExpectedType pat_ty argTypeKind
 		-- If pat_ty is Expected, this returns the appropriate
 		-- SigmaType.  In Infer mode, we create a fresh type variable.
@@ -245,10 +243,10 @@ tc_pat ctxt (SigPatIn pat sig) pat_ty thing_inside
 	  (sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig
  	; tcSubPat sig_ty pat_ty
 	; subst <- refineTyVars sig_tvs	-- See note [Type matching]
-	; let tv_binds = [(tv, substTyVar subst  tv) | tv <- sig_tvs]
+	; let tv_binds = [(tyVarName tv, substTyVar subst tv) | tv <- sig_tvs]
 	      sig_ty'  = substTy subst sig_ty
 	; (pat', tvs, res) 
-	      <- tcExtendTyVarEnv3 tv_binds $
+	      <- tcExtendTyVarEnv2 tv_binds $
 		 tc_lpat ctxt pat (Check sig_ty') thing_inside
 
 	; return (SigPatOut pat' sig_ty, tvs, res) }
@@ -500,17 +498,15 @@ refineAlt :: PatCtxt -> DataCon
 	    -> TcM a -> TcM a
 refineAlt ctxt con ex_tvs ctxt_tys pat_tys thing_inside 
   = do	{ old_subst <- getTypeRefinement
-	; let refiner | can_i_refine ctxt = gadtRefineTys
-		      | otherwise         = gadtMatchTys
-	; case refiner ex_tvs old_subst pat_tys ctxt_tys of
+	; case gadtRefineTys bind_fn old_subst pat_tys ctxt_tys of
 		Failed msg -> failWithTc (inaccessibleAlt msg)
 		Succeeded new_subst -> do {
 	  traceTc (text "refineTypes:match" <+> ppr con <+> ppr new_subst)
 	; setTypeRefinement new_subst thing_inside } }
 
   where
-    can_i_refine (LamPat can_refine) = can_refine
-    can_i_refine other_ctxt 	     = False
+    bind_fn tv | isMetaTyVar tv = WildCard	-- Wobbly types behave as wild cards
+	       | otherwise	= BindMe
 \end{code}
 
 Note [Type matching]
@@ -539,7 +535,7 @@ refineTyVars :: [TcTyVar] 	-- Newly instantiated meta-tyvars of the function
 -- Just one level of de-wobblification though.  What a hack! 
 refineTyVars tvs
   = do	{ mb_prs <- mapM mk_pr tvs
-	; return (mkTvSubst (mkVarEnv (catMaybes mb_prs))) }
+	; return (mkOpenTvSubst (mkVarEnv (catMaybes mb_prs))) }
   where
     mk_pr tv = do { details <- readMetaTyVar tv
 		  ; case details of