From: simonpj@microsoft.com <unknown>
Date: Wed, 10 Sep 2008 09:58:16 +0000 (+0000)
Subject: Check the *right* set of type variables for escape!
X-Git-Tag: 2008-09-12~22
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=62ee856ca84f409741f472ce3527d6deafa5b62a

Check the *right* set of type variables for escape!

I did the wrong checkSigTyVars, which (happily) triggered an ASSERT
failure.  This should fix it.
---

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 97db7b3..466cee9 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -588,7 +588,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
               rigid_info   = InstSkol
               origin       = SigOrigin rigid_info
               inst_ty      = idType dfun_id
-        ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
+        ; (inst_tvs', theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
                 -- inst_head_ty is a PredType
 
         ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
@@ -620,7 +620,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
 
 	-- It's possible that the superclass stuff might unified something
 	-- in the envt with one of the clas_tyvars
-	; checkSigTyVars class_tyvars
+	; checkSigTyVars inst_tvs'
 
         ; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict)
 
@@ -628,8 +628,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
         ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
 
         ; return (unitBag $ noLoc $
-                  AbsBinds  tvs (map instToVar dfun_dicts)
-                            [(tvs, dfun_id, instToId this_dict, [])]
+                  AbsBinds inst_tvs' (map instToVar dfun_dicts)
+                            [(inst_tvs', dfun_id, instToId this_dict, [])]
                             (dict_bind `consBag` sc_binds)) }
   where
       -----------------------
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 6ff9732..1a3fad7 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -421,7 +421,7 @@ pprUserTypeCtxt SpecInstCtxt    = ptext (sLit "a SPECIALISE instance pragma")
 tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar)
 -- Tidy the type inside a GenSkol, preparatory to printing it
 tidySkolemTyVar env tv
-  = ASSERT( isSkolemTyVar tv || isSigTyVar tv )
+  = ASSERT( isTcTyVar tv && (isSkolemTyVar tv || isSigTyVar tv ) )
     (env1, mkTcTyVar (tyVarName tv) (tyVarKind tv) info1)
   where
     (env1, info1) = case tcTyVarDetails tv of
@@ -508,7 +508,7 @@ isTyConableTyVar tv
 	SkolemTv {}	    -> False
 	
 isSkolemTyVar tv 
-  = ASSERT( isTcTyVar tv )
+  = ASSERT2( isTcTyVar tv, ppr tv )
     case tcTyVarDetails tv of
 	SkolemTv _         -> True
  	MetaTv _ _         -> False
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 367536b..94af19c 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -2039,7 +2039,7 @@ check_sig_tyvars
 check_sig_tyvars _ []
   = return ()
 check_sig_tyvars extra_tvs sig_tvs
-  = ASSERT( all isSkolemTyVar sig_tvs )
+  = ASSERT( all isTcTyVar sig_tvs && all isSkolemTyVar sig_tvs )
     do  { gbl_tvs <- tcGetGlobalTyVars
         ; traceTc (text "check_sig_tyvars" <+> (vcat [text "sig_tys" <+> ppr sig_tvs,
                                       text "gbl_tvs" <+> ppr gbl_tvs,