From: Manuel M T Chakravarty <chak@cse.unsw.edu.au>
Date: Wed, 1 Oct 2008 14:43:39 +0000 (+0000)
Subject: Proper error message for unsupported pattern signatures
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=33770e2e376005ff14a1d16b89f32b0d474425e2

Proper error message for unsupported pattern signatures
- Pattern signatures must be identical to the type expected for the pattern;
  see Note [Pattern coercions]
- We now signal an appropriate error if an equality coercion would be needed
  (instead of just generating Core that doesn't typecheck)

  MERGE TO 6.10
---

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 3a8326f..8ea9b13 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -35,6 +35,7 @@ import TcIface
 import TcType
 import {- Kind parts of -} Type
 import Var
+import Coercion
 import TyCon
 import Class
 import Name
@@ -763,16 +764,17 @@ tcPatSig :: UserTypeCtxt
 	 -> LHsType Name
 	 -> BoxySigmaType
 	 -> TcM (TcType,	   -- The type to use for "inside" the signature
-		 [(Name,TcType)])  -- The new bit of type environment, binding
+		 [(Name, TcType)], -- The new bit of type environment, binding
 				   -- the scoped type variables
+                 CoercionI)        -- Coercion due to unification with actual ty
 tcPatSig ctxt sig res_ty
   = do	{ (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig
 
 	; if null sig_tvs then do {
 		-- The type signature binds no type variables, 
 		-- and hence is rigid, so use it to zap the res_ty
-		  boxyUnify sig_ty res_ty
-		; return (sig_ty, [])
+		  coi <- boxyUnify sig_ty res_ty
+		; return (sig_ty, [], coi)
 
 	} else do {
 		-- Type signature binds at least one scoped type variable
@@ -795,7 +797,8 @@ tcPatSig ctxt sig res_ty
 		-- unifying, and reading out the results.
 		-- This is a strictly local operation.
 	; box_tvs <- mapM tcInstBoxyTyVar sig_tvs
-	; boxyUnify (substTyWith sig_tvs (mkTyVarTys box_tvs) sig_ty) res_ty
+	; coi <- boxyUnify (substTyWith sig_tvs (mkTyVarTys box_tvs) sig_ty) 
+                           res_ty
 	; sig_tv_tys <- mapM readFilledBox box_tvs
 
 		-- Check that each is bound to a distinct type variable,
@@ -805,7 +808,7 @@ tcPatSig ctxt sig res_ty
 	; check binds_in_scope tv_binds
 	
 		-- Phew!
-	; return (res_ty, tv_binds)
+	; return (res_ty, tv_binds, coi)
 	} }
   where
     check _ [] = return ()
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 2a2409e..fd28455 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -422,7 +422,10 @@ tc_pat pstate (orig@(ViewPat expr pat _)) overall_pat_ty thing_inside
 -- Type signatures in patterns
 -- See Note [Pattern coercions] below
 tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
-  = do	{ (inner_ty, tv_binds) <- tcPatSig (patSigCtxt pstate) sig_ty pat_ty
+  = do	{ (inner_ty, tv_binds, coi) <- tcPatSig (patSigCtxt pstate) sig_ty 
+                                                                    pat_ty
+        ; unless (isIdentityCoercion coi) $ 
+            failWithTc (badSigPat pat_ty)
 	; (pat', tvs, res) <- tcExtendTyVarEnv2 tv_binds $
 			      tc_lpat pat inner_ty pstate thing_inside
 	; return (SigPatOut pat' inner_ty, tvs, res) }
@@ -992,6 +995,10 @@ polyPatSig sig_ty
   = hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
        2 (ppr sig_ty)
 
+badSigPat :: TcType -> SDoc
+badSigPat pat_ty = ptext (sLit "Pattern signature must exactly match:") <+> 
+                   ppr pat_ty
+
 badTypePat :: Pat Name -> SDoc
 badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat