From: simonpj@microsoft.com <unknown>
Date: Tue, 25 Aug 2009 07:30:59 +0000 (+0000)
Subject: Fix Trac #3406 (albeit not very satisfactorily): scoped type variables
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f670c47f9f93ffd6d06b331cd40554cd5e92484c

Fix Trac #3406 (albeit not very satisfactorily): scoped type variables

The issue here is this:

  type ItemColID a b = Int  -- Discards a,b

  get :: ItemColID a b -> a -> ItemColID a b
  get (x :: ItemColID a b) = x :: ItemColID a b

The pattern signature for 'x' doesn't actually rigidly bind a,b.
This crashed GHC 6.10 with a 'readFilledBox' panic.  Now we fail
with an erroe message

With the new outside-in algorithm we'll be able to accept this program.
---

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index d64461f..91ef46f 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -39,6 +39,7 @@ import TcIface
 import TcType
 import {- Kind parts of -} Type
 import Var
+import VarSet
 import Coercion
 import TyCon
 import Class
@@ -48,6 +49,7 @@ import PrelNames
 import TysWiredIn
 import BasicTypes
 import SrcLoc
+import Util
 import UniqSupply
 import Outputable
 import FastString
@@ -891,6 +893,16 @@ tcPatSig ctxt sig res_ty
 	  	-- Check that pat_ty is rigid
 	; checkTc (isRigidTy res_ty) (wobblyPatSig sig_tvs)
 
+		-- Check that all newly-in-scope tyvars are in fact
+		-- constrained by the pattern.  This catches tiresome
+		-- cases like	
+		--	type T a = Int
+		--	f :: Int -> Int
+		-- 	f (x :: T a) = ...
+		-- Here 'a' doesn't get a binding.  Sigh
+	; let bad_tvs = filterOut (`elemVarSet` exactTyVarsOfType sig_ty) sig_tvs
+	; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs)
+
 		-- Now match the pattern signature against res_ty
 		-- For convenience, and uniform-looking error messages
 		-- we do the matching by allocating meta type variables, 
@@ -1041,6 +1053,15 @@ wobblyPatSig sig_tvs
 		<+> pprQuotedList sig_tvs)
        2 (ptext (sLit "unless the pattern has a rigid type context"))
 		
+badPatSigTvs :: TcType -> [TyVar] -> SDoc
+badPatSigTvs sig_ty bad_tvs
+  = vcat [ fsep [ptext (sLit "The type variable") <> plural bad_tvs, 
+                 quotes (pprWithCommas ppr bad_tvs), 
+          	 ptext (sLit "should be bound by the pattern signature") <+> quotes (ppr sig_ty),
+	  	 ptext (sLit "but are actually discarded by a type synonym") ]
+         , ptext (sLit "To fix this, expand the type synonym") 
+         , ptext (sLit "[Note: I hope to lift this restriction in due course]") ]
+
 scopedNonVar :: Name -> Type -> SDoc
 scopedNonVar n ty
   = vcat [sep [ptext (sLit "The scoped type variable") <+> quotes (ppr n),