X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=43bcb4520d0ef817ae392080fd881ea3be7df352;hb=5237f0f57fc16e6584be98d5139dde57819ad689;hp=4c56b083bbbd39c0b5066dd88284568c5d3b9c63;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 4c56b08..43bcb45 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -33,7 +33,7 @@ import TcType		( TcType, TcTyVar, TcSigmaType, TcRhoType,
 			  emptyTvSubst, substTyVar, substTy, mkTopTvSubst, zipTopTvSubst, zipOpenTvSubst,
 			  mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy,
 			  mkFunTy, mkFunTys, exactTyVarsOfTypes,
-			  tidyOpenTypes )
+			  tidyOpenType, tidyOpenTypes )
 import VarSet		( elemVarSet, mkVarSet )
 import Kind		( liftedTypeKind, openTypeKind )
 import TcUnify		( boxySplitTyConApp, boxySplitListTy, 
@@ -129,7 +129,7 @@ tcCheckExistentialPat (LetPat _) pats ex_tvs pat_tys body_ty
   = failWithTc (existentialExplode pats)
 
 tcCheckExistentialPat ctxt pats ex_tvs pat_tys body_ty
-  = addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs pat_tys)	$
+  = addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs pat_tys body_ty)	$
     checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs
 
 data PatState = PS {
@@ -278,7 +278,7 @@ tc_pat pstate (BangPat pat) pat_ty thing_inside
   = do	{ (pat', tvs, res) <- tc_lpat pstate pat pat_ty thing_inside
 	; return (BangPat pat', tvs, res) }
 
--- There's a wrinkle with irrefuatable patterns, namely that we
+-- There's a wrinkle with irrefutable patterns, namely that we
 -- must not propagate type refinement from them.  For example
 --	data T a where { T1 :: Int -> T Int; ... }
 --	f :: T a -> Int -> a
@@ -293,8 +293,14 @@ tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside
 				  thing_inside pstate
 					-- Ignore refined pstate',
 					-- revert to pstate
+	-- Check no existentials
 	; if (null pat_tvs) then return ()
 	  else lazyPatErr lpat pat_tvs
+
+	-- Check that the pattern has a lifted type
+	; pat_tv <- newBoxyTyVar liftedTypeKind
+	; boxyUnify pat_ty (mkTyVarTy pat_tv)
+
 	; return (LazyPat pat', [], res) }
 
 tc_pat pstate (WildPat _) pat_ty thing_inside
@@ -404,6 +410,8 @@ tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
     
 	; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
 	; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
+
+tc_pat _ _other_pat _ _ = panic "tc_pat" 	-- DictPat, ConPatOut, SigPatOut, VarPatOut
 \end{code}
 
 
@@ -683,8 +691,7 @@ newLitInst orig lit res_ty	-- Make a LitInst
   = do 	{ loc <- getInstLoc orig
 	; res_tau <- zapToMonotype res_ty
 	; new_uniq <- newUnique
-	; let
- 		lit_nm   = mkSystemVarName new_uniq FSLIT("lit")
+	; let	lit_nm   = mkSystemVarName new_uniq FSLIT("lit")
 		lit_inst = LitInst lit_nm lit res_tau loc
 	; extendLIE lit_inst
 	; return (HsVar (instToId lit_inst)) }
@@ -774,19 +781,18 @@ existentialExplode pats
 		text "In the binding group for"])
 	4 (vcat (map ppr pats))
 
-sigPatCtxt bound_ids bound_tvs tys tidy_env 
-  = 	-- tys is (body_ty : pat_tys)  
-    mapM zonkTcType tys		`thenM` \ tys' ->
-    let
-	(env1,  tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
-	(_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
-    in
-    returnM (env1,
+sigPatCtxt bound_ids bound_tvs pat_tys body_ty tidy_env 
+  = do	{ pat_tys' <- mapM zonkTcType pat_tys
+	; body_ty' <- zonkTcType body_ty
+	; let (env1,  tidy_tys)    = tidyOpenTypes tidy_env (map idType show_ids)
+	      (env2, tidy_pat_tys) = tidyOpenTypes env1 pat_tys'
+	      (env3, tidy_body_ty) = tidyOpenType  env2 body_ty'
+	; return (env3,
 		 sep [ptext SLIT("When checking an existential match that binds"),
 		      nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 		      ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
 		      ptext SLIT("The body has type:") <+> ppr tidy_body_ty
-		])
+		]) }
   where
     show_ids = filter is_interesting bound_ids
     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs