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

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 4c56b08..ee33d4a 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -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
@@ -683,8 +689,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)) }