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 (file)
--- 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 (file)
--- 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 (file)
--- 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,