From bcacf0b79872953f5512c0ebd98d551a30306b49 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 7 Mar 2005 15:17:02 +0000
Subject: [PATCH] [project @ 2005-03-07 15:16:58 by simonpj]
 -----------------------------------------        Fix
 scoping bug for quantified type variables 
 -----------------------------------------

	Merge to STABLE

When instantiating a declaration type signature, make sure to instantiate
fresh names for non-scoped type variables, else they may be spuriously shared.
Turns out that the test lib/Generics/reify tests this, which is good.

Comments are with TcMType.tcInstSigType
---
 ghc/compiler/typecheck/TcBinds.lhs |   21 +++++++++------------
 ghc/compiler/typecheck/TcMType.lhs |   34 ++++++++++++++++++++++++----------
 2 files changed, 33 insertions(+), 22 deletions(-)

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index c4e1b92..b1bfc65 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -14,7 +14,7 @@ import {-# SOURCE #-} TcExpr  ( tcCheckSigma, tcCheckRho )
 import CmdLineOpts	( DynFlag(Opt_MonomorphismRestriction) )
 import HsSyn		( HsExpr(..), HsBind(..), LHsBinds, Sig(..),
 			  LSig, Match(..), HsBindGroup(..), IPBind(..), 
-			  HsType(..), hsLTyVarNames, isVanillaLSig,
+			  HsType(..), HsExplicitForAll(..), hsLTyVarNames, isVanillaLSig,
 			  LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds,
 			  collectHsBindBinders, collectPatBinders, pprPatBind
 			)
@@ -593,21 +593,18 @@ tcTySig :: LSig Name -> TcM TcSigInfo
 tcTySig (L span (Sig (L _ name) ty))
   = setSrcSpan span		$
     do	{ sigma_ty <- tcHsSigType (FunSigCtxt name) ty
-	; (tvs, theta, tau) <- tcInstSigType name sigma_ty
+	; (tvs, theta, tau) <- tcInstSigType name scoped_names sigma_ty
 	; loc <- getInstLoc (SigOrigin (SigSkol name))
-
-	; let poly_id = mkLocalId name sigma_ty
-
+	; return (TcSigInfo { sig_id = mkLocalId name sigma_ty, 
+			      sig_tvs = tvs, sig_theta = theta, sig_tau = tau, 
+			      sig_scoped = scoped_names, sig_loc = loc }) }
+  where
 		-- The scoped names are the ones explicitly mentioned
 		-- in the HsForAll.  (There may be more in sigma_ty, because
 		-- of nested type synonyms.  See Note [Scoped] with TcSigInfo.)
-	      scoped_names = case ty of
-				L _ (HsForAllTy _ tvs _ _) -> hsLTyVarNames tvs
-				other 		    	   -> []
-
-	; return (TcSigInfo { sig_id = poly_id, sig_scoped = scoped_names,
-			      sig_tvs = tvs, sig_theta = theta, sig_tau = tau, 
-			      sig_loc = loc }) }
+    scoped_names = case ty of
+			L _ (HsForAllTy Explicit tvs _ _) -> hsLTyVarNames tvs
+			other 		    		  -> []
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 46968f5..4a9df50 100644
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -77,7 +77,7 @@ import Var		( TyVar, tyVarKind, tyVarName,
 -- others:
 import TcRnMonad          -- TcType, amongst others
 import FunDeps		( grow )
-import Name		( Name, setNameUnique, mkSysTvName, mkSystemName, getOccName )
+import Name		( Name, setNameUnique, mkSysTvName )
 import VarSet
 import VarEnv
 import CmdLineOpts	( dopt, DynFlag(..) )
@@ -174,24 +174,38 @@ tcInstType ty = tc_inst_type (mappM tcInstTyVar) ty
 
 
 ---------------------------------------------
-tcInstSigType :: Name -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
+tcInstSigType :: Name -> [Name] -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
 -- Instantiate a type with fresh SigSkol variables
 -- See Note [Signature skolems] in TcType.
 -- 
--- Tne new type variables have the sane Name as the original.
--- We don't need a fresh unique, because the renamer has made them
+-- Tne new type variables have the sane Name as the original *iff* they are scoped.
+-- For scoped tyvars, we don't need a fresh unique, because the renamer has made them
 -- unique, and it's better not to do so because we extend the envt
 -- with them as scoped type variables, and we'd like to avoid spurious
 -- 's = s' bindings in error messages
-tcInstSigType id_name ty = tc_inst_type (tcInstSigTyVars id_name) ty
+--
+-- For non-scoped ones, we *must* instantiate fresh ones:
+--	
+--	type T = forall a. [a] -> [a]
+--	f :: T; 
+--	f = g where { g :: T; g = <rhs> }
+--
+-- We must not use the same 'a' from the defn of T at both places!!
+
+tcInstSigType id_name scoped_names ty = tc_inst_type (tcInstSigTyVars id_name scoped_names) ty
 
-tcInstSigTyVars :: Name -> [TyVar] -> TcM [TcTyVar]
-tcInstSigTyVars id_name tyvars
+tcInstSigTyVars :: Name -> [Name] -> [TyVar] -> TcM [TcTyVar]
+tcInstSigTyVars id_name scoped_names tyvars
   = mapM new_tv tyvars
   where
-    new_tv tv = do { ref <- newMutVar Flexi ;
-		   ; return (mkTcTyVar (tyVarName tv) (tyVarKind tv) 
-				       (SigSkolTv id_name ref)) }
+    new_tv tv 
+      = do { let name = tyVarName tv
+	   ; ref <- newMutVar Flexi
+	   ; name' <- if name `elem` scoped_names 
+		      then return name
+		      else do { uniq <- newUnique; return (setNameUnique name uniq) }
+	   ; return (mkTcTyVar name' (tyVarKind tv) 
+			       (SigSkolTv id_name ref)) }
 			    
 
 ---------------------------------------------
-- 
1.7.10.4