From: simonpj <unknown>
Date: Wed, 3 Jan 2001 11:40:04 +0000 (+0000)
Subject: [project @ 2001-01-03 11:40:04 by simonpj]
X-Git-Tag: Approximately_9120_patches~2983
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e7d7b535eb4d3a729173c72edd3da56c16a4b726;p=ghc-hetmet.git

[project @ 2001-01-03 11:40:04 by simonpj]
Dont quantify over monomorphic type variables
---

diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs
index 6a2a0b3..7550e73 100644
--- a/ghc/compiler/typecheck/TcRules.lhs
+++ b/ghc/compiler/typecheck/TcRules.lhs
@@ -19,7 +19,7 @@ import TcType		( zonkTcTypes, zonkTcTyVarToTyVar, newTyVarTy )
 import TcIfaceSig	( tcCoreExpr, tcCoreLamBndrs, tcVar )
 import TcMonoType	( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars )
 import TcExpr		( tcExpr )
-import TcEnv		( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing )
+import TcEnv		( tcExtendLocalValEnv, tcExtendTyVarEnv, tcGetGlobalTyVars, isLocalThing )
 import Rules		( extendRuleBase )
 import Inst		( LIE, plusLIEs, instToId )
 import Id		( idType, idName, mkVanillaId )
@@ -108,8 +108,14 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
 
 	-- Gather type variables to quantify over
 	-- and turn them into real TyVars (just as in TcBinds.tcBindWithSigs)
-    zonkTcTypes (rule_ty : map idType tpl_ids)				`thenNF_Tc` \ zonked_tys ->
-    mapTc zonkTcTyVarToTyVar (varSetElems (tyVarsOfTypes zonked_tys))	`thenTc` \ tvs ->
+    zonkTcTypes (rule_ty : map idType tpl_ids)	`thenNF_Tc` \ zonked_tys ->
+    tcGetGlobalTyVars				`thenNF_Tc` \ free_tyvars ->
+    let
+	poly_tyvars = tyVarsOfTypes zonked_tys `minusVarSet` free_tyvars
+	-- There can be tyvars free in the environment, if there are
+	-- monomorphic overloaded top-level bindings.  Sigh.
+    in
+    mapTc zonkTcTyVarToTyVar (varSetElems poly_tyvars)	`thenTc` \ tvs ->
 
 	-- RHS can be a bit more lenient.  In particular,
 	-- we let constant dictionaries etc float outwards